home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / EDITOR.LSP < prev    next >
Lisp/Scheme  |  1994-02-05  |  111KB  |  2,786 lines

  1. (in-package "LISP")
  2. (export '(editor ed *use-ed*))
  3. (pushnew 'editor *features*)
  4. #+(or DOS OS/2) (eval-when (compile load eval) (pushnew 'dose *features*))
  5. (in-package "EDITOR")
  6.  
  7. ;###############################################################################
  8. ;;;; Screen-Verwaltung, dritte Version
  9. ;;;;
  10. ;;;; Michael Stoll, Februar 1992
  11. ;;;; Bruno Haible, Mai 1992
  12. ;;;;
  13. ;;;; Spezifikation siehe SCREEN2.DOC
  14.  
  15. (defvar *window*) ; aktuelles Ausgabefenster
  16. (defvar global-screen-height) ; Höhe des Fensters
  17. (defvar global-screen-width)  ; Breite des Fensters
  18. (defvar blanks) ; Array voller Spaces
  19.  
  20. (defmacro with-window (&body body)
  21.   `(LET ((*WINDOW* (SCREEN:MAKE-WINDOW)))
  22.      (UNWIND-PROTECT
  23.        (MULTIPLE-VALUE-BIND (GLOBAL-SCREEN-HEIGHT GLOBAL-SCREEN-WIDTH) (SCREEN:WINDOW-SIZE *WINDOW*)
  24.          (LET ((BLANKS (MAKE-STRING GLOBAL-SCREEN-WIDTH :INITIAL-ELEMENT #\SPACE)))
  25.            ,@body
  26.        ) )
  27.        (CLOSE *WINDOW*)
  28.    ) )
  29. )
  30.  
  31. ;;; Zunächst einige Macros zur Bildschirmsteuerung
  32.  
  33. (defmacro bell () `(WRITE-CHAR #\Bell *TERMINAL-IO*))
  34.  
  35. (defmacro screen-set-cursor (lin col)
  36.   `(SCREEN:SET-WINDOW-CURSOR-POSITION *WINDOW* ,lin ,col)
  37. )
  38.  
  39. (defmacro screen-home ()
  40.   `(SCREEN-SET-CURSOR 0 0)
  41. )
  42.  
  43. (defmacro screen-clear-screen ()
  44.   `(SCREEN:CLEAR-WINDOW *WINDOW*)
  45. )
  46.  
  47. (defmacro screen-clear-end-of-screen ()
  48.   `(SCREEN:CLEAR-WINDOW-TO-EOT *WINDOW*)
  49. )
  50.  
  51. (defmacro screen-clear-end-of-line ()
  52.   `(SCREEN:CLEAR-WINDOW-TO-EOL *WINDOW*)
  53. )
  54.  
  55. (defmacro screen-insert-line ()
  56.   `(SCREEN:INSERT-WINDOW-LINE *WINDOW*)
  57. )
  58.  
  59. (defmacro screen-delete-line ()
  60.   `(SCREEN:DELETE-WINDOW-LINE *WINDOW*)
  61. )
  62.  
  63. (defmacro screen-cursor-on ()
  64.   `(SCREEN:WINDOW-CURSOR-ON *WINDOW*)
  65. )
  66.  
  67. (defmacro screen-cursor-off ()
  68.   `(SCREEN:WINDOW-CURSOR-OFF *WINDOW*)
  69. )
  70.  
  71. (defmacro screen-reverse-on ()
  72.   `(SCREEN:HIGHLIGHT-ON *WINDOW*)
  73. )
  74.  
  75. (defmacro screen-reverse-off ()
  76.   `(SCREEN:HIGHLIGHT-OFF *WINDOW*)
  77. )
  78.  
  79. ;-------------------------------------------------------------------------------
  80.  
  81. ;;; Es werden drei Arten von Koordinaten verwendet:
  82. ;;; (Immer zuerst Zeile, dann Spalte)
  83. ;;;
  84. ;;; (a) Bildschirmkoordinaten
  85. ;;; =========================
  86. ;;;    Sie bezeichnen den Ort auf dem Bildschirm. Der erlaubte Bereich ist
  87. ;;;    [0..global-screen-height[ x [0..global-screen-width[. Dabei ist Zeile 0
  88. ;;;    die oberste Zeile, Spalte 0 die linkeste Spalte.
  89. ;;;
  90. ;;; (b) Fensterkoordinaten
  91. ;;; ======================
  92. ;;;    Sie beziehen sich jeweils auf ein Fenster. Der Ursprung ist dabei die
  93. ;;;    linke obere Ecke des Fensterinneren (d.h. ohne Rahmen). Der erlaubte
  94. ;;;    Bereich ist für ein Fenster screen im Falle, daß es nicht der ganze
  95. ;;;    Bildschirm ist (d.h. screen.full? = nil)
  96. ;;;    [-1..screen.height+1[ x [-1..screen.width+1[, wobei die Randwerte sich
  97. ;;;    auf Orte im Rahmen beziehen. Umfaßt das Fenster den ganzen Bildschirm,
  98. ;;;    sind die Fensterkoordinaten mit den Bildschirmkoordinaten identisch.
  99. ;;;
  100. ;;; (c) Textkoordinaten
  101. ;;; ===================
  102. ;;;    Sie beziehen sich auf den Text, der in einem Fenster dargestellt wird.
  103. ;;;    Die Zeilenkoordinate läuft im Bereich [0..length(screen.text)[, die
  104. ;;;    zur Zeilenkoordineate lin gehörige Spaltenkoordinate läuft im Bereich
  105. ;;;    [0..length(screen.text[lin])[ (manchmal auch einschließlich der rechten
  106. ;;;    Grenze).
  107. ;;;
  108. ;;; Umrechnung:
  109. ;;; ===========
  110. ;;; (a) -> (b):
  111. ;;;   (lin, col) --> (lin - screen.phys-top-lin, col - screen.phys-left-col)
  112. ;;; (b) -> (c):
  113. ;;;   (lin, col) --> (lin + screen.top-lin, col + screen.left-col)
  114.  
  115. ;-------------------------------------------------------------------------------
  116.  
  117. ;;; Datenstrukturen für Screens
  118.  
  119. ;; Eine ZEILE ist ein String, adjustable mit Fill-pointer.
  120.  
  121. ;; Liefert neue Zeile der Größe >= size und der Länge size
  122. (defun get-new-line (size)
  123.   (make-array size
  124.               :element-type 'string-char
  125.               :adjustable t :fill-pointer size
  126. ) )
  127.  
  128. ;; Ein TEXT ist ein Push-Vektor von Zeilen.
  129. (defun make-empty-text (&optional (len global-screen-height))
  130.   (let ((text (make-array len :adjustable t :fill-pointer 0)))
  131.     (vector-push (get-new-line 0) text)
  132.     text
  133. ) )
  134.  
  135. ;; Eine MARKE besteht aus zwei Integers >= 0 (Zeile, Spalte)
  136. (defmacro make-mark (lin col) `(CONS ,lin ,col))
  137. (defmacro mark-lin (mark) `(CAR ,mark))
  138. (defmacro mark-col (mark) `(CDR ,mark))
  139.  
  140. ;; Die Marke (lin,col) heißt für den Text text GÜLTIG, wenn gilt
  141. ;; 0 <= lin < length(text), 0 <= col <= length(text[lin])
  142. ;; (Marken sind immer in Textkoordinaten angegeben.)
  143.  
  144. ;; Ein SCREEN besteht u.a. aus einem Text mit Cursorposition und Marken, sowie
  145. ;; Angaben über den Fensterausschnitt und die physikalische Lage auf dem Schirm
  146. (defstruct (screen (:copier nil) (:constructor mk-screen))
  147.   (text (make-empty-text))    ; Text des Screens
  148.   (lin 0 :type integer)       ; Cursorzeile
  149.   (col 0 :type integer)       ; Cursorspalte, (lin,col) ist für den Text gültig
  150.   (saved-col 0 :type integer) ; gemerkte Spalte
  151.   (marks (make-array 12 :adjustable t :fill-pointer 12 :initial-element nil))
  152.     ; Vektor von Marken, die für den Text gültig sind, oder NIL; Länge >= 12.
  153.     ; Die ersten beiden bestimmen den markierten Block.
  154.   (height global-screen-height :type integer) ; Höhe des Bildausschnitts
  155.   (width  global-screen-width  :type integer) ; Breite des Bildausschnitts
  156.   (top-lin  0 :type integer) ; Index der obersten Zeile im Fenster
  157.   (left-col 0 :type integer) ; Index der linkesten Spalte im Fenster
  158.                              ; (Textkoordinaten)
  159.   (visibility nil :type vector) ; Vektor von Listen von Conses: Zu jeder Zeile
  160.                                 ;  die sichtbaren Abschnitte
  161.   (full? t)                  ; Flag, ob ganzer Schirm
  162.   (phys-left-col 0 :type integer) ; physikalische Koordinaten der linken oberen
  163.   (phys-top-lin  0 :type integer) ; Fensterecke (ohne Rahmen)
  164.                                   ; (Bildschirmkoordinaten)
  165.   (title "" :type string)    ; Titel, nur wenn nicht full?
  166. )
  167.  
  168. ;; Bedingungen:
  169. ;; 0 <= top-lin < length(text)
  170. ;; 0 <= left-col
  171.  
  172. ;; 0 <= phys-left-col
  173. ;; phys-left-col + width <= global-screen-width
  174. ;; 0 <= phys-top-lin
  175. ;; phys-top-lin + height <= global-screen-height
  176. ;; Falls not full?: jeweils < statt <=
  177.  
  178. ;; visibility ist ein Vektor der Länge height + 2, Einträge sind Listen
  179. ;; ((l_1 . r_1) (l_2 . r_2) ... (l_n . r_n)) mit
  180. ;; -1 <= l_1 < r_1 < l_2 < r_2 < ... < l_n < r_n <= width + 1.
  181. ;; Bedeutung der Liste visibility[i]: Von Zeile i-1 (Zeile -1 ist die
  182. ;; Titelzeile, Zeile height die untere Rahmenzeile, analog für Spalten
  183. ;; -1, width; das sind Fensterkoordinaten) sind die Abschnitte
  184. ;; [l_1..r_1[, [l_2..r_2[, ..., [l_n..r_n[ sichtbar.
  185.  
  186. ;; make-screen erzeugt einen Screen. Ohne Argumente erhält man einen Screen,
  187. ;; der den ganzen Bildschirm umfaßt, ansonsten einen mit Rahmen.
  188. (defun make-screen (&key height width left-col top-lin title)
  189.   (if (or height width left-col top-lin title)
  190.     ;; wenigstens ein Argument angegeben
  191.     (let ((min-height 1) (min-width 10))
  192.       (setq height
  193.             (max min-height ; Höhe in den erlaubten Bereich bringen (>= min-height)
  194.               (if height
  195.                 (min height (- global-screen-height 2))
  196.                 ;; Default: Zwei Drittel der Bildschirmhöhe
  197.                 (- (floor (* global-screen-height 0.67s0)) 2)
  198.       )     ) )
  199.       (setq width
  200.             (max min-width ; Breite in den erlaubten Bereich bringen (>= min-width)
  201.               (if width
  202.                 (min width (- global-screen-width 2))
  203.                 ;; Default: Halbe Bildschirmbreite
  204.                 (- (ash global-screen-width -1) 2)
  205.       )     ) )
  206.       (if top-lin
  207.         ;; Oberste Zeile in den erlaubten Bereich bringen und ggfs. Höhe
  208.         ;; anpassen
  209.         (setq top-lin (min (max 1 top-lin) (- global-screen-height min-height 1))
  210.               height (min height (- global-screen-height top-lin 1))
  211.         )
  212.         ;; Default: So, daß Fenster in der Mitte sitzt
  213.         (setq top-lin (max 1 (ash (- global-screen-height height) -1)))
  214.       )
  215.       (if left-col
  216.         ;; Linkeste Spalte in den erlaubten Bereich bringen und ggfs. Breite
  217.         ;; anpassen
  218.         (setq left-col (min (max 1 left-col) (- global-screen-width min-width 1))
  219.               width (min width (- global-screen-width left-col 1))
  220.         )
  221.         ;; Default: So, daß Fenster in der Mitte sitzt
  222.         (setq left-col (max 1 (ash (- global-screen-width width) -1)))
  223.       )
  224.       (mk-screen :height height :width width :full? nil :title (or title "")
  225.                  :phys-left-col left-col :phys-top-lin top-lin
  226.                  :text (make-empty-text height)
  227.                  :visibility (make-array (+ height 2) :initial-element '())
  228.     ) )
  229.     (mk-screen :visibility
  230.                (make-array (+ global-screen-height 2) :initial-element '())
  231. ) ) )
  232.  
  233. ;-------------------------------------------------------------------------------
  234.  
  235. ;; Hilfsfunktion: Testet, ob gegebener adjustable Array mit Fillpointer
  236. ;; groß genug ist, und vergrößert, wenn nicht
  237. ;; Fill-pointer wird auf neue Größe gesetzt
  238. (defun resize-array (array size &optional (increment 10))
  239.   (if (>= (array-dimension array 0) size)
  240.     (setf (fill-pointer array) size)
  241.     (adjust-array array (+ size increment) :fill-pointer size)
  242. ) )
  243.  
  244. ;; Hilfsfunktion: verringert den Fill-Pointer eines gegebenen
  245. ;; adjustable Array und löscht die dabei wegfallenden Elemente.
  246. (defun shrink-array (array delta)
  247.   (let* ((end (fill-pointer array))
  248.          (start (- end delta)))
  249.     (setf (fill-pointer array) start)
  250.     (when (eq (array-element-type array) 'T)
  251.       (do ((index start (1+ index)))
  252.           ((eql index end))
  253.         (setf (aref array index) nil)
  254. ) ) ) )
  255.  
  256. ;-------------------------------------------------------------------------------
  257.  
  258. ;;; Funktionen für das Textfenster (intern)
  259.  
  260. ;; Ausgabe eines mit Leerstellen gefüllten Zeilenstücks:
  261. (defun display-blanks (left-col right-col)
  262.   #+ATARI
  263.   (write-string blanks *window* :end (- right-col left-col))
  264.   #-ATARI
  265.   ; Auf Terminals sind diese vielen Leerstellen laangsaam...
  266.   (let ((count (- right-col left-col)))
  267.     (if (and (> count 3) (eql right-col global-screen-width))
  268.       (screen-clear-end-of-line)
  269.       (write-string blanks *window* :end count)
  270.   ) )
  271. )
  272.  
  273. ;; Ausgabe einer Zeile:
  274. ;; line:     auszugebende Zeile
  275. ;; mark-start, mark-end:   NIL oder zu markierender Bereich der Zeile
  276. ;; [left-col..right-col[:  darzustellendes Intervall der Zeile
  277. ;; left-arrow?: Flag, ob in der ersten Spalte ein Pfeil nach rechts ausgegeben
  278. ;;              werden soll, wenn dort ein Zeichen stünde
  279. ;; right-arrow? : Analog für die letzte Spalte
  280. ;; Cursor muß sich an der richtigen Position auf dem Bildschirm befinden,
  281. ;; reverse off, wrap off
  282. ;; right-col - left-col >= [left-arrow?] + [right-arrow?]
  283. (defun display-line (line mark-start mark-end left-col right-col
  284.                      #+(or ATARI DOSE) left-arrow? #+(or ATARI DOSE) right-arrow?
  285.                     )
  286.   (unless (> (length line) left-col) ; Zeile vorher zu Ende
  287.     (display-blanks left-col right-col)
  288.     (return-from display-line)
  289.   )
  290.   #+(or ATARI DOSE)
  291.   (when left-arrow? ; Pfeil nach links ist evtl. auszugeben
  292.     (write-char #+ATARI #\Code4 #+DOSE #\Code17 *window*) ; Pfeil nach links
  293.     (incf left-col) ; jetzt right-col - left-col >= [right-arrow?]
  294.   ) ; hier stets length(line) >= left-col
  295.   (let ((right-col-1 right-col))
  296.     #+(or ATARI DOSE)
  297.     (when right-arrow? (decf right-col-1)) ; Pfeil nach rechts ist evtl. auszugeben
  298.     (let ((end-col (min (length line) right-col-1))) ; stets end-col >= left-col
  299.       (cond
  300.         ((or (null mark-start) (null mark-end)
  301.              (<= mark-end left-col) (>= mark-start end-col)
  302.          )
  303.           ;; Zeile ganz außerhalb des markierten Bereichs
  304.           (write-string line *window* :start left-col :end end-col)
  305.         )
  306.         ((and (<= mark-start left-col) (<= end-col mark-end))
  307.           ;; Zeile ganz innerhalb des markierten Bereichs: reverse darstellen
  308.           (screen-reverse-on)
  309.           (write-string line *window* :start left-col :end end-col)
  310.           (screen-reverse-off)
  311.         )
  312.         (t ;; sonst: markierten Teil herauspicken und reverse darstellen
  313.            (setq mark-start (max mark-start left-col))
  314.            (setq mark-end (min mark-end end-col))
  315.            (write-string line *window* :start left-col :end mark-start)
  316.            (screen-reverse-on)
  317.            (write-string line *window* :start mark-start :end mark-end)
  318.            (screen-reverse-off)
  319.            (write-string line *window* :start mark-end :end end-col)
  320.       ) )
  321.       (if (eql end-col (length line)) ; Zeile vor dem rechten Rand zu Ende?
  322.         (display-blanks end-col right-col)
  323.         #+(or ATARI DOSE)
  324.         (when right-arrow?
  325.           (write-char #+ATARI #\Code3 #+DOSE #\Code16 *window*) ; Pfeil nach rechts
  326.         )
  327. ) ) ) )
  328.  
  329. ;; Ausgabe eines Zeilenstücks:
  330. ;; Zeile lin des screens von Spalte left (einschl.) bis right (ausschl.)
  331. ;; anzeigen (Fensterkoordinaten)
  332. (let ((ohchar #-DOSE #\= #+DOSE #\Code205) ; oberer horizontaler Balken
  333.       (olchar #-DOSE #\# #+DOSE #\Code213) ; obere linke Ecke
  334.       (orchar #-DOSE #\# #+DOSE #\Code184) ; obere rechte Ecke
  335.       (uhchar #-DOSE #\- #+DOSE #\Code196) ; unterer horizontaler Balken
  336.       (ulchar #-DOSE #\+ #+DOSE #\Code192) ; untere linke Ecke
  337.       (urchar #-DOSE #\+ #+DOSE #\Code217) ; untere rechte Ecke
  338.       (lvchar #-DOSE #\| #+DOSE #\Code179) ; linker vertikaler Balken
  339.       (rvchar #-DOSE #\| #+DOSE #\Code179) ; rechter vertikaler Balken
  340.      )
  341.   (defun show-screen-line (screen lin left right)
  342.     (let ((height (screen-height screen)) ; Größe und Position des Screens
  343.           (width (screen-width screen))
  344.           (phys-left-col (screen-phys-left-col screen))
  345.           (phys-top-lin (screen-phys-top-lin screen))
  346.          )
  347.       ;; Bereichsüberschreitungen abfangen:
  348.       (if (screen-full? screen)
  349.         (setq left (max left 0) right (min right width))
  350.         (setq left (max left -1) right (min right (+ width 1)))
  351.       )
  352.       (when (and (> right left) ; Trifft angegebener Bereich das Fenster?
  353.                  (if (screen-full? screen) (< -1 lin height) (<= -1 lin height))
  354.             )
  355.         ;; Cursor positionieren
  356.         (screen-set-cursor (+ phys-top-lin lin) (+ phys-left-col left))
  357.         (cond
  358.           ((eql lin -1) ; Titelzeile
  359.             (let* ((title (screen-title screen))
  360.                    (tstr (string-concat
  361.                            (string olchar)
  362.                            (if (< (length title) width)
  363.                              (format nil "~V,,0,V:@<~A~>" width ohchar title)
  364.                              (subseq title 0 width)
  365.                            )
  366.                            (string orchar)
  367.                   ))     )
  368.               (write-string tstr *window* :start (1+ left) :end (1+ right))
  369.           ) )
  370.           ((eql lin height) ; untere Rahmenzeile
  371.             (when (eql left -1) (write-char ulchar *window*) (setq left 0))
  372.             (dotimes (i (- (if (eql right (+ width 1)) width right) left))
  373.               (write-char uhchar *window*)
  374.             )
  375.             (when (eql right (+ width 1)) (write-char urchar *window*))
  376.           )
  377.           (t (let* ((text (screen-text screen))
  378.                     (text-lin (+ lin (screen-top-lin screen)))
  379.                     (left-col (screen-left-col screen))
  380.                     (line (if (< text-lin (length text))
  381.                             (aref text text-lin)
  382.                             ""
  383.                     )     )
  384.                     (marks (screen-marks screen))
  385.                     (mark-start (aref marks 0)) ; Blockanfang
  386.                     (mark-end (aref marks 1))   ; Blockende
  387.                    )
  388.                ;; evtl. Stück vom linken Rahmen
  389.                (when (eql left -1) (write-char lvchar *window*) (setq left 0))
  390.                ;; Teil der Zeile ausgeben
  391.                (display-line
  392.                  line
  393.                  ;; Beginn Markierung oder nil
  394.                  (and mark-start
  395.                       (cond ((eql (mark-lin mark-start) text-lin)
  396.                               (mark-col mark-start)
  397.                             )
  398.                             ((< (mark-lin mark-start) text-lin) 0)
  399.                             (t nil)
  400.                  )    )
  401.                  ;; Ende Markierung oder nil
  402.                  (and mark-end
  403.                       (cond ((eql (mark-lin mark-end) text-lin)
  404.                               (mark-col mark-end)
  405.                             )
  406.                             ((> (mark-lin mark-end) text-lin) (length line))
  407.                             (t nil)
  408.                  )    )
  409.                  ;; linke Spalte (Textkoord.)
  410.                  (+ left-col left)
  411.                  ;; rechte Spalte + 1 (Textkoord.)
  412.                  (+ left-col (min right width))
  413.                  ;; Left-Arrow, falls left-col > 0 und erste Fensterspalte
  414.                  ;; dargestellt wird
  415.                  #+(or ATARI DOSE) (and (plusp left-col) (eql left 0))
  416.                  ;; Right-Arrow, falls letzte Fensterspalte
  417.                  ;; dargestellt wird
  418.                  #+(or ATARI DOSE) (>= right width)
  419.                )
  420.                ;; evtl. Stück vom rechten Rahmen
  421.                (when (eql right (+ width 1)) (write-char rvchar *window*))
  422.   ) ) ) ) )  )
  423. )
  424.  
  425. ;; Ausgabe eines Zeilenstücks:
  426. ;; Zeile lin des screens (im Inneren) von Spalte left (einschl.) bis right
  427. ;; (ausschl.) (Fensterkoordinaten) anzeigen unter Berücksichtigung des
  428. ;; visibility-Vektors.
  429. (defun show-screen-line-v (screen lin left right)
  430.   (let ((height (screen-height screen))
  431.         (width (screen-width screen))
  432.         (visibility (screen-visibility screen))
  433.        )
  434.     ;; Bereichsüberschreitungen abfangen:
  435.     (setq left (max left 0) right (min right width))
  436.     (when (and (< left right) (< -1 lin height))
  437.       ;; trifft angegebener Bereich das Fensterinnere?
  438.       ;; Ja: dann die einzelnen Abschnitte abarbeiten
  439.       (dolist (part (aref visibility (1+ lin)))
  440.         (when (and (> (cdr part) left) (< (car part) right))
  441.           (show-screen-line screen lin (max left (car part))
  442.                                        (min right (cdr part))
  443. ) ) ) ) ) )
  444.  
  445. ;; Ausgabe eines Fensters:
  446. ;; screen: Auszugebendes Textfenster
  447. ;; start-lin: Zeile, ab der angezeigt werden soll
  448. ;; end-lin: Zeile, bis vor die angezeigt werden soll (Fensterkoordinaten)
  449. ;; 0 <= start-lin <= end-lin <= screen.height
  450. ;; Liefert screen zurück.
  451. ;; reverse off, wrap off
  452. (defun display-screen (screen &optional (start-lin 0)
  453.                                         (end-lin (screen-height screen))
  454.                       )
  455.   (do ((width (screen-width screen))
  456.        (screen-lin start-lin (1+ screen-lin))
  457.       )
  458.       ((eql screen-lin end-lin) t)
  459.     (show-screen-line-v screen screen-lin 0 width)
  460. ) )
  461.  
  462. ;;; Funktionen zur Verwaltung der visibility-Vektoren
  463.  
  464. ;; Nimm aus einer visibility-Liste das Intervall [left..right[ heraus
  465. (defun update-visibility-list-1 (vl left right)
  466.   ;; Entferne die Einträge, die ganz verdeckt werden
  467.   (setq vl (delete-if #'(lambda (pair)
  468.                           (and (<= left (car pair)) (<= (cdr pair) right))
  469.                         )
  470.                       vl
  471.   )        )
  472.   ;; Bestimme die Einträge (falls vorhanden), in deren Bereich eine der Grenzen
  473.   ;; fällt: diese müssen verkürzt werden
  474.   (let ((left-v (member-if #'(lambda (pair) (< (car pair) left (cdr pair))) vl))
  475.         (right-v (member-if #'(lambda (pair) (< (car pair) right (cdr pair))) vl)))
  476.     ;; (car left-v) und (car right-v) sind zu verkürzen:
  477.     (if (and left-v right-v (eq left-v right-v))
  478.       ;; zu entfernender Bereich innerhalb eines Teilintervalls: in zwei teilen
  479.       ; (... (A . B) ...) --> (... (A . left) (right . B) ...)
  480.       (push (cons right (shiftf (cdr (car left-v)) left)) (cdr left-v))
  481.       (progn
  482.         (when left-v (setf (cdr (car left-v)) left))
  483.         (when right-v (setf (car (car right-v)) right))
  484.   ) ) )
  485.   ;; veränderte Liste zurückgeben
  486.   vl
  487. )
  488.  
  489. ;; Füge in eine visibility-Liste das Intervall [left..right[ ein (unter der
  490. ;; Annahme, daß es zu den vorhandenen Intervallen disjunkt ist).
  491. (defun update-visibility-list-2 (vl left right)
  492.   (let ((vl1 nil) (vl2 vl))
  493.     (loop ; vl1 und vl2 laufen durch die Liste vl.
  494.           ; Entweder vl1 = nil oder (cdr vl1) = vl2.
  495.           ; Das Intervall [left..right[ ist jedenfalls nach vl1 einzufügen.
  496.       (when (or (null vl2) (<= right (caar vl2))) (return))
  497.       (shiftf vl1 vl2 (cdr vl2))
  498.     )
  499.     ; Das Intervall ist zwischen vl1 und vl2 einzukleben.
  500.     (if (or (null vl2) (< right (caar vl2)))
  501.       (push (cons left right) vl2)
  502.       (setf (caar vl2) left) ; ersetze (caar vl2) = right durch left
  503.     )
  504.     ; Nun ist (caar vl2) = left. vl2 ist an vl1 anzuschließen.
  505.     (if (null vl1)
  506.       (setq vl vl2)
  507.       (if (eql (cdar vl1) left)
  508.         ; (car vl1) und (car vl2) vereinigen:
  509.         (setf (cdar vl1) (cdar vl2) (cdr vl1) (cdr vl2))
  510.         ; vl2 als (cdr vl1) anschließen:
  511.         (setf (cdr vl1) vl2)
  512.   ) ) )
  513.   vl
  514. )
  515.  
  516. ;; Nimm aus dem visibility-Vektor von Screen den Bereich heraus, der durch
  517. ;; [top-lin..bot-lin[ x [left-col..right-col[ (in Bildschirmkoordinaten)
  518. ;; gegeben ist.
  519. (defun update-visibility (screen top-lin bot-lin left-col right-col)
  520.   (let* ((s-top-lin (screen-phys-top-lin screen))
  521.          (s-left-col (screen-phys-left-col screen))
  522.          (visibility (screen-visibility screen))
  523.          ;; Umrechnen auf Fensterkoordinaten
  524.          (rel-top-lin (max -1 (- top-lin s-top-lin)))
  525.          (rel-bot-lin (min (+ (screen-height screen) 1) (- bot-lin s-top-lin)))
  526.          (rel-left-col (max -1 (- left-col s-left-col)))
  527.          (rel-right-col (min (+ (screen-width screen) 1) (- right-col s-left-col)))
  528.         )
  529.     (when (and (> rel-bot-lin rel-top-lin) (> rel-right-col rel-left-col))
  530.       ;; Schnitt ist nicht leer
  531.       (do ((index (1+ rel-top-lin) (1+ index))
  532.            (end-index (1+ rel-bot-lin))
  533.           )
  534.           ((eql index end-index))
  535.         ;; Für jede Zeile im Schnitt visibility-Liste updaten
  536.         (setf (aref visibility index)
  537.               (update-visibility-list-1 (aref visibility index)
  538.                                         rel-left-col rel-right-col
  539. ) ) ) ) )     )
  540.  
  541. ;; Mache alle Screens der Liste screens im Bereich lin, [left..right[
  542. ;; (Bildschirmkoordinaten) sichtbar, soweit sie sich nicht überlappen.
  543. ;; (Vorher waren sie dort nicht sichtbar gewesen.)
  544. ;; Die visibility-Listen werden entsprechend aktualisiert.
  545. (defun show-newly-visible-line-parts (screens lin left right)
  546.   (unless (null screens) ; nur etwas zu tun, wenn Screens vorhanden
  547.     (let* ((screen (first screens))
  548.            (screens (rest screens))
  549.            ;; Wir können hier davon ausgehen, daß jeder Screen einen Rand
  550.            ;; der Breite 1 hat, denn der einzige Screen mit full? = nil
  551.            ;; ist der ganze Bildschirm, und dessen "Rand" wäre unsichtbar.
  552.            ;; (Es ist ja 0 <= left < right <= global-screen-width und
  553.            ;; und 0 <= lin < global-screen-height.)
  554.            (height (screen-height screen))
  555.            (width+1 (+ (screen-width screen) 1))
  556.            (left-col (screen-phys-left-col screen))
  557.            (visibility (screen-visibility screen))
  558.            ;; Umrechnen auf Fensterkoordinaten
  559.            (rel-lin (- lin (screen-phys-top-lin screen)))
  560.            (rel-left (- left left-col))
  561.            (rel-right (- right left-col))
  562.           )
  563.       (if (and (<= -1 rel-lin height) (<= 0 rel-right) (< rel-left width+1))
  564.         ;; Screen screen ist betroffen
  565.         (progn
  566.           ;; visibility-Liste updaten
  567.           (setf (aref visibility (1+ rel-lin))
  568.                 (update-visibility-list-2 (aref visibility (1+ rel-lin))
  569.                                           (max -1 rel-left)
  570.                                           (min width+1 rel-right)
  571.           )     )
  572.           ;; falls nötig, links darunter liegende Screens ansprechen
  573.           (when (< rel-left -1)
  574.             (show-newly-visible-line-parts screens lin left (1- left-col))
  575.           )
  576.           ;; betroffenes Zeilenstück ausgeben
  577.           (show-screen-line screen rel-lin rel-left rel-right)
  578.           ;; falls nötig, rechts darunter liegende Screens ansprechen
  579.           (when (> rel-right width+1)
  580.             (show-newly-visible-line-parts screens lin (+ left-col width+1) right)
  581.         ) )
  582.         ;; sonst direkt zu den nächsten Screens weitergehen
  583.         (show-newly-visible-line-parts screens lin left right)
  584. ) ) ) )
  585.  
  586. ;-------------------------------------------------------------------------------
  587.  
  588. ;;; Implementierung der Interface-Funktionen
  589.  
  590. ;; Liste der auf dem Bildschirm dargestellten Screens, geordnet nach ihrer
  591. ;; Verdeckungs-Rangfolge (d.h. der oberste zuerst).
  592. (defvar *screens* '())
  593.  
  594. ;; Cursorposition im screen setzen (Textkoordinaten), Wert T.
  595. (defun set-cursor (screen lin &optional (col (screen-saved-col screen) col-s))
  596.   (let* ((text (screen-text screen))
  597.          (text-len (length text)))
  598.     ;; Bereichsüberschreitungen abfangen:
  599.     (setq lin (max 0 (min lin (1- text-len))))
  600.     (setq col (max 0 (min col (length (aref text lin)))))
  601.     ;; neue Position vermerken
  602.     (setf (screen-lin screen) lin (screen-col screen) col)
  603.     ;; falls Spalte angegeben, gemerkte Spalte setzen
  604.     (when col-s (setf (screen-saved-col screen) col))
  605.     t
  606. ) )
  607.  
  608. ;; vertikales Scrollen eines Textfensters; upgedateter screen wird zurück-
  609. ;; gegeben
  610. ;; n > 0: n Zeilen nach oben scrollen
  611. ;; n = 0: nichts tun
  612. ;; n < 0: -n Zeilen nach unten scrollen
  613. ;; flag /= nil: Cursor mitverschieben
  614. (defun scroll-vertical (screen n &optional (flag nil))
  615.   (let* ((text (screen-text screen))
  616.          (text-len (length text))
  617.          (top-lin (screen-top-lin screen))
  618.         )
  619.     ;; evtl. Cursor updaten
  620.     (when flag (set-cursor screen (+ (screen-lin screen) n)))
  621.     ;; Bereichsüberschreitungen abfangen:
  622.     (setq n (max (- top-lin) (min n (- text-len 1 top-lin))))
  623.     ;; Datenstruktur updaten
  624.     (setf (screen-top-lin screen) (+ top-lin n))
  625.     (when (eql n 0) (return-from scroll-vertical screen))
  626.     (cond ((or (> (abs n) 10)
  627.                (not (screen-full? screen))
  628.                (null *screens*)
  629.                (not (eq screen (first *screens*)))
  630.            )
  631.             ;; n groß oder nicht der ganze Bildschirm oder nicht oberster
  632.             ;; Screen: Fenster neu schreiben
  633.             (display-screen screen)
  634.           )
  635.           ((plusp n) ; nach oben
  636.             (screen-home)
  637.             (dotimes (i n) (screen-delete-line))
  638.             (display-screen screen (- (screen-height screen) n))
  639.           )
  640.           (t ; nach unten
  641.             (screen-home)
  642.             (dotimes (i (- n)) (screen-insert-line))
  643.             (display-screen screen 0 (- n))
  644. ) ) )     )
  645.  
  646. ;; horizontales Scrollen des Textfensters; upgedateter screen zurück
  647. ;; n > 0: um n Spalten nach links scrollen
  648. ;; n = 0: nichts tun
  649. ;; n < 0: um -n Spalten nach rechts scrollen
  650. (defun scroll-horizontal (screen n)
  651.   (let ((left-col (screen-left-col screen)))
  652.     (when (minusp (+ left-col n)) (setq n (- left-col)))
  653.     (if (eql n 0)
  654.       screen
  655.       (progn (setf (screen-left-col screen) (+ left-col n))
  656.              (display-screen screen)
  657. ) ) ) )
  658.  
  659. ;; Cursor setzen und Textfenster ggfs. so verändern, daß Cursor im Fenster ist,
  660. ;; Cursor einschalten - nur wenn oberster Screen
  661. ;; center: Flag, ob Cursor möglichst in der Mitte erscheinen soll
  662. ;; liefert T zurück
  663. (defun set-cursor-visible (screen &optional (center nil))
  664.   (let* ((lin (screen-lin screen))
  665.          (col (screen-col screen))
  666.          (top-lin (screen-top-lin screen))
  667.          (left-col (screen-left-col screen))
  668.          (height (screen-height screen))
  669.          (width (screen-width screen))
  670.         )
  671.     (cond
  672.       ((<= (if (eql left-col 0) 0 (1+ left-col)) col (+ left-col width -2))
  673.         ;; Cursorspalte im Fensterbereich
  674.         (cond
  675.           ((< lin top-lin)
  676.             ;; Cursorzeile über dem Fenster -> nach unten scrollen
  677.             (scroll-vertical screen
  678.                              (- lin top-lin (if center (ash height -1) 0))
  679.           ) )
  680.           ((>= lin (+ top-lin height))
  681.             ;; Cursorzeile unter dem Fenster -> nach oben scrollen
  682.             (scroll-vertical screen
  683.                         (- lin top-lin -1 (if center (ash height -1) height))
  684.       ) ) ) )
  685.       ((<= top-lin lin (+ top-lin height -1))
  686.         ;; Cursorzeile im Fensterbereich, Cursorspalte aber nicht ->
  687.         ;;  nach rechts oder links scrollen
  688.         (scroll-horizontal screen
  689.             (- col left-col
  690.                (if (or center (< width 40))
  691.                  (ash width -1)
  692.                  (if (<= col left-col) (- width 20) 20)
  693.       ) )   )  )
  694.       ;; sonst: Fensterausschnitt neu setzen
  695.       (t (let ((new-left-col (if (< col (1- width))
  696.                                0
  697.                                (- col (if (or center (< width 40))
  698.                                         (ash width -1)
  699.                                         20
  700.                )             ) )      )
  701.                (new-top-lin (max 0 (- lin (ash height -1))))
  702.               )
  703.            (setf (screen-left-col screen) new-left-col
  704.                  (screen-top-lin screen) new-top-lin
  705.            )
  706.            (display-screen screen)
  707.   ) ) )  )
  708.   (when (and *screens* (eq screen (first *screens*))) ; oberster Screen?
  709.     (screen-set-cursor                    ; Cursor setzen
  710.       (+ (- (screen-lin screen) (screen-top-lin screen))
  711.          (screen-phys-top-lin screen)
  712.       )
  713.       (+ (- (screen-col screen) (screen-left-col screen))
  714.          (screen-phys-left-col screen)
  715.     ) )
  716.     (screen-cursor-on)                    ; und einschalten
  717.   )
  718.   t
  719. )
  720.  
  721. ;; Zeile lin ab Spalte col (Textkoordinaten) auffrischen, Wert T.
  722. (defun refresh-line (screen lin col)
  723.   (show-screen-line-v screen (- lin (screen-top-lin screen))
  724.                              (- col (screen-left-col screen))
  725.                              (screen-width screen)
  726.   )
  727.   t
  728. )
  729.  
  730. ;; Fenster ab Zeile lin bis vor Zeile end-lin (Textkoordinaten) auffrischen,
  731. ;; ab Zeile end-lin um |n| Zeilen scrollen (n>0: nach oben, n<0: nach unten),
  732. ;; Wert T.
  733. (defun refresh-screen (screen lin end-lin &optional (n 0))
  734.   (let ((top-lin (screen-top-lin screen))
  735.         (height (screen-height screen)))
  736.     (when (<= (+ top-lin height) lin)
  737.       ;; Bildschirminhalt kann unverändert bleiben
  738.       (return-from refresh-screen t)
  739.     )
  740.     (when (<= end-lin top-lin)
  741.       ;; Bildschirminhalt kann unverändert bleiben
  742.       (setf (screen-top-lin screen) (+ top-lin n))
  743.       (return-from refresh-screen t)
  744.     )
  745.     ;; Bildschirminhalt muß teilweise gescrollt werden
  746.     (when (or (> (abs n) 10)
  747.               (not (screen-full? screen))
  748.               (null *screens*)
  749.               (not (eq screen (first *screens*)))
  750.           )
  751.       ;; n groß oder nicht der ganze Bildschirm oder nicht oberster
  752.       ;; Screen: Fenster neu schreiben
  753.       (display-screen screen)
  754.       (return-from refresh-screen t)
  755.     )
  756.     ;; Scrollen
  757.     (cond ((minusp n) ; nach unten
  758.             (setq end-lin (max end-lin (- top-lin n)))
  759.             ; Wir haben  end-lin >= top-lin + |n|  erzwungen.
  760.             (let ((scroll-top (- (+ end-lin n) top-lin))) ; >=0
  761.               (when (< (- scroll-top n) height)
  762.                 (screen-set-cursor scroll-top 0)
  763.                 (dotimes (i (- n)) (screen-insert-line))
  764.           ) ) )
  765.           ((plusp n) ; nach oben
  766.             (let ((scroll-top (- end-lin top-lin))) ; >0
  767.               (when (< scroll-top height)
  768.                 (if (>= (+ scroll-top n) height)
  769.                   (display-screen screen scroll-top height)
  770.                   (progn
  771.                     (screen-set-cursor scroll-top 0)
  772.                     (dotimes (i n) (screen-delete-line))
  773.                     (display-screen screen (- height n) height)
  774.     )     ) ) ) ) )
  775.     ;; Bereich zwischen lin und end-lin anzeigen
  776.     (let ((screen-lin (max 0 (- lin top-lin)))
  777.           (screen-end-lin (min (- end-lin top-lin) height)))
  778.       (when (< screen-lin screen-end-lin)
  779.         (display-screen screen screen-lin screen-end-lin)
  780.   ) ) )
  781.   t
  782. )
  783.  
  784. ;; Fenster vom Bildschirm nehmen, Wert: neuer oberster Screen, falls vorhanden,
  785. ;; sonst NIL
  786. (defun hide-screen (screen)
  787.   (let* ((height+2 (+ (screen-height screen) 2))
  788.          (top-lin (screen-phys-top-lin screen))
  789.          (left-col (screen-phys-left-col screen))
  790.          (visibility (screen-visibility screen))
  791.          ;; screen in *screens* suchen
  792.          (screens (member screen *screens* :test #'eq))
  793.         )
  794.     (when screens ; wenn nicht da, ist nichts zu tun
  795.       (do ((index 0 (1+ index))
  796.            (lin (1- top-lin) (1+ lin))
  797.           )
  798.           ((eql index height+2))
  799.         ;; Zeilen einzeln durchgehen
  800.         (dolist (part (aref visibility index))
  801.           ;; freiwerdende Teile anzeigen
  802.           (show-newly-visible-line-parts
  803.             (rest screens) lin (+ left-col (car part)) (+ left-col (cdr part))
  804.         ) )
  805.         ;; Sichtbarkeit löschen
  806.         (setf (aref visibility index) '())
  807.       )
  808.       ;; screen aus den aktiven Screens entfernen
  809.       (setq *screens* (delete screen *screens* :test #'eq))
  810.     )
  811.     (first *screens*)
  812. ) )
  813.  
  814. ;; Fenster nach oben bringen
  815. (defun activate-screen (screen)
  816.   (let* ((height (screen-height screen))
  817.          (width (screen-width screen))
  818.          (top-lin (screen-phys-top-lin screen))
  819.          (left-col (screen-phys-left-col screen))
  820.          (bot-lin (+ top-lin height))
  821.          (right-col (+ left-col width))
  822.          (visibility (screen-visibility screen))
  823.          (left 0)
  824.          (right width)
  825.         )
  826.     (unless (and (not (null *screens*)) (eq screen (first *screens*)))
  827.       ;; falls schon oben, ist nichts zu tun
  828.       (unless (screen-full? screen)
  829.         ;; Rahmen berücksichtigen
  830.         (decf top-lin) (incf bot-lin)
  831.         (decf left-col) (incf right-col)
  832.         (decf left) (incf right)
  833.       )
  834.       ;; [top-lin..bot-lin[ x [left-col..right-col[ ist Screenbereich auf
  835.       ;; dem Bildschirm (in Bildschirmkoordinaten)
  836.       (do ((screens *screens* (rest screens)))
  837.           ((or (null screens) (eq (first screens) screen)))
  838.         ;; visibility updaten für darüber gewesenen Screen
  839.         (update-visibility (first screens) top-lin bot-lin left-col right-col)
  840.       )
  841.       ;; screen in der Liste nach vorne bringen
  842.       (setq *screens* (cons screen (delete screen *screens* :test #'eq)))
  843.       ;; visibility-Listen setzen und Zeilen anzeigen, wenn nötig
  844.       (if (screen-full? screen)
  845.         (dotimes (lin height)
  846.           (let ((new-vl (list (cons left right))))
  847.             (unless (equal (aref visibility (1+ lin)) new-vl)
  848.               (setf (aref visibility (1+ lin)) new-vl)
  849.               (show-screen-line screen lin left right)
  850.         ) ) )
  851.         (dotimes (lin (+ height 2))
  852.           (let ((new-vl (list (cons left right))))
  853.             (unless (equal (aref visibility lin) new-vl)
  854.               (setf (aref visibility lin) new-vl)
  855.               (show-screen-line screen (1- lin) left right)
  856.   ) ) ) ) ) )
  857.   t
  858. )
  859.  
  860. ;; Cursor und Marken mitführen bei Einfüge- und Löschoperationen
  861. (defun update-marks (screen lin1 col1 lin2 col2)
  862.   (flet ((new-lin-col (lin col) ; Berechne neue Koordinaten
  863.            (cond
  864.              ((eql lin1 lin2) ; alles in einer Zeile
  865.                (if (eql lin lin1) ; ändert sich nur, wenn in dieser Zeile
  866.                  (if (< col1 col)
  867.                    (values lin (+ col (- col2 col1)))
  868.                    (values lin (min col col2))
  869.                  )
  870.                  (values lin col)
  871.              ) )
  872.              ((> lin1 lin2) ; Löschen eines Textteils über mehrere Zeilen
  873.                (cond ((eql lin lin2) (values lin (min col col2)))
  874.                      ((eql lin lin1)
  875.                        (values lin2 (max (+ col (- col2 col1)) col2))
  876.                      )
  877.                      ((< lin2 lin lin1) (values lin2 col2))
  878.                      ((< lin1 lin) (values (+ lin (- lin2 lin1)) col))
  879.                      (t (values lin col))
  880.              ) )
  881.              (t (cond ((eql lin lin1) ; Einfügen eines Textteils über mehrere
  882.                         (if (> col col1) ; Zeilen
  883.                           (values lin2 (+ col (- col2 col1)))
  884.                           (values lin col)
  885.                       ) )
  886.                       ((< lin1 lin) (values (+ lin (- lin2 lin1)) col))
  887.                       (t (values lin col))
  888.         )) ) )  )
  889.     (let ((lin (screen-lin screen))
  890.           (col (screen-col screen))
  891.          )
  892.       ;; Cursor updaten
  893.       (if (and (eql lin lin1) (eql col col1))
  894.         (setf (screen-lin screen) lin2
  895.               (screen-col screen) col2
  896.               (screen-saved-col screen) col2
  897.         )
  898.         (multiple-value-bind (new-lin new-col) (new-lin-col lin col)
  899.           (setf (screen-lin screen) new-lin
  900.                 (screen-col screen) new-col
  901.     ) ) ) )
  902.     (let ((marks (screen-marks screen)))
  903.       ;; Marken updaten
  904.       (dotimes (i (length marks))
  905.         (let ((mark (aref marks i)))
  906.           (when mark
  907.             (multiple-value-bind (new-lin new-col)
  908.                 (new-lin-col (mark-lin mark) (mark-col mark))
  909.               (setf (mark-lin mark) new-lin
  910.                     (mark-col mark) new-col
  911. ) ) ) ) ) ) ) )
  912.  
  913. ;; Screen scrollen um n nach oben, dabei Cursor mitführen
  914. (defun scroll-screen (screen n)
  915.   (scroll-vertical screen n t)
  916.   t
  917. )
  918.  
  919. ;###############################################################################
  920. ;;;; Full-Screen-Editor
  921. ;;;;
  922. ;;;; Michael Stoll, Jan./Feb. 1992
  923. ;;;; Bruno Haible 30.3.1992, 13.5.1992
  924.  
  925. ;===========================================================================
  926. ;  G R U N D F U N K T I O N E N   Z U R   T E X T M A N I P U L A T I O N
  927. ;===========================================================================
  928.  
  929. ;; Liste der bei Undo durchzuführenden Aktionen:
  930. (defvar *undo* '())
  931.  
  932. #|
  933. ; erstrangige, alles Bisherige überschattende Undo-Aktion:
  934. (defun undo1 (function)
  935.   (setq *undo* (list function))
  936. )
  937.  
  938. ; zweitrangige, akkumulierende Undo-Aktion:
  939. (defun undo2 (function)
  940.   (push function *undo*)
  941. )
  942.  
  943. ; drittrangige, nur Cursor-bewegende, Undo-Aktion:
  944. (defun undo3 (screen)
  945.   (let ((function
  946.           (let ((lin (screen-lin screen))
  947.                 (col (screen-col screen)))
  948.             #'(lambda () (set-cursor screen lin col))
  949.        )) )
  950.     (undo2 function)
  951. ) )
  952. |# ; vorerst:
  953. (defun undo1 (function) (declare (ignore function)))
  954. (defun undo2 (function) (declare (ignore function)))
  955. (defun undo3 (screen) (declare (ignore screen)))
  956.  
  957. ;-------------------------------------------------------------------------------
  958.  
  959. ;;; Cursor-Bewegung
  960.  
  961. (defun cursor-up (screen)
  962.   #+DEUTSCH "Cursor nach oben"
  963.   #+ENGLISH "cursor up"
  964.   (let ((lin (screen-lin screen)))
  965.     (and (plusp lin)
  966.          (progn (undo3 screen) (set-cursor screen (1- lin)))
  967. ) ) )
  968.  
  969. (defun cursor-down (screen)
  970.   #+DEUTSCH "Cursor nach unten"
  971.   #+ENGLISH "cursor down"
  972.   (let ((lin (screen-lin screen)))
  973.     (and (< lin (1- (length (screen-text screen))))
  974.          (progn (undo3 screen) (set-cursor screen (1+ lin)))
  975. ) ) )
  976.  
  977. (defun cursor-left (screen)
  978.   #+DEUTSCH "Cursor nach links"
  979.   #+ENGLISH "cursor left"
  980.   (let ((lin (screen-lin screen))
  981.         (col (screen-col screen)))
  982.     (cond ((plusp col) (decf col))
  983.           ((plusp lin)
  984.             (decf lin) (setq col (length (aref (screen-text screen) lin))) )
  985.           (t (return-from cursor-left nil))
  986.     )
  987.     (undo3 screen)
  988.     (set-cursor screen lin col)
  989. ) )
  990.  
  991. (defun cursor-right (screen)
  992.   #+DEUTSCH "Cursor nach rechts"
  993.   #+ENGLISH "cursor right"
  994.   (let ((text (screen-text screen))
  995.         (lin (screen-lin screen))
  996.         (col (screen-col screen)))
  997.     (cond ((< col (length (aref text lin))) (incf col))
  998.           ((< lin (1- (length text))) (incf lin) (setq col 0))
  999.           (t (return-from cursor-right nil))
  1000.     )
  1001.     (undo3 screen)
  1002.     (set-cursor screen lin col)
  1003. ) )
  1004.  
  1005. (defun cursor-to-start-of-line (screen)
  1006.   #+DEUTSCH "Cursor an den Zeilenanfang"
  1007.   #+ENGLISH "cursor to start of line"
  1008.   (let ((lin (screen-lin screen)))
  1009.     (undo3 screen)
  1010.     (set-cursor screen lin 0)
  1011. ) )
  1012.  
  1013. (defun cursor-to-end-of-line (screen)
  1014.   #+DEUTSCH "Cursor ans Zeilenende"
  1015.   #+ENGLISH "cursor to end of line"
  1016.   (let ((lin (screen-lin screen)))
  1017.     (undo3 screen)
  1018.     (set-cursor screen lin (length (aref (screen-text screen) lin)))
  1019. ) )
  1020.  
  1021. (defun cursor-to-start-of-text (screen)
  1022.   #+DEUTSCH "Cursor an den Textanfang"
  1023.   #+ENGLISH "cursor to start of text"
  1024.   (undo3 screen)
  1025.   (set-cursor screen 0 0)
  1026. )
  1027.  
  1028. (defun cursor-to-end-of-text (screen)
  1029.   #+DEUTSCH "Cursor ans Textende"
  1030.   #+ENGLISH "cursor to end of text"
  1031.   (undo3 screen)
  1032.   (let* ((text (screen-text screen))
  1033.          (text-len-1 (1- (length text))))
  1034.     (set-cursor screen text-len-1 (length (aref text text-len-1)))
  1035. ) )
  1036.  
  1037. (defun page-up (screen)
  1038.   #+DEUTSCH "Seite nach oben"
  1039.   #+ENGLISH "page up"
  1040.   (undo3 screen)
  1041.   (scroll-screen screen (- 1 (screen-height screen)))
  1042. )
  1043.  
  1044. (defun page-down (screen)
  1045.   #+DEUTSCH "Seite nach unten"
  1046.   #+ENGLISH "page down"
  1047.   (undo3 screen)
  1048.   (scroll-screen screen (- (screen-height screen) 1))
  1049. )
  1050.  
  1051. (defun line-up (screen)
  1052.   #+DEUTSCH "Zeile nach oben"
  1053.   #+ENGLISH "line up"
  1054.   (undo3 screen)
  1055.   (scroll-screen screen -1)
  1056. )
  1057.  
  1058. (defun line-down (screen)
  1059.   #+DEUTSCH "Zeile nach unten"
  1060.   #+ENGLISH "line down"
  1061.   (undo3 screen)
  1062.   (scroll-screen screen 1)
  1063. )
  1064.  
  1065. ;-------------------------------------------------------------------------------
  1066.  
  1067. ;; Marken
  1068.  
  1069. (defun set-mark-fn (n)
  1070.   (let ((index (+ n 2)))
  1071.     (labels ((set-mark (screen &optional (lin (screen-lin screen))
  1072.                                          (col (screen-col screen)) )
  1073.                (undo2 (let ((mark-n (aref (screen-marks screen) index)))
  1074.                         (if mark-n
  1075.                           #'(lambda () (setf (aref (screen-marks screen) index) nil))
  1076.                           (let ((old-lin (mark-lin mark-n)) (old-col (mark-col mark-n)))
  1077.                             #'(lambda () (set-mark screen old-lin old-col))
  1078.                )      ) ) )
  1079.                (setf (aref (screen-marks screen) index) (make-mark lin col))
  1080.             ))
  1081.       #'set-mark
  1082. ) ) )
  1083. (defun set-mark-doc (n)
  1084.   (format nil #+DEUTSCH "Marke ~D setzen"
  1085.               #+ENGLISH "set mark ~D"
  1086.               n
  1087. ) )
  1088.  
  1089. (defun cursor-to-mark-fn (n)
  1090.   (let ((index (+ n 2)))
  1091.     #'(lambda (screen)
  1092.         (undo3 screen)
  1093.         (let ((mark (aref (screen-marks screen) index)))
  1094.           (and mark (set-cursor screen (mark-lin mark) (mark-col mark)))
  1095.       ) )
  1096. ) )
  1097. (defun cursor-to-mark-doc (n)
  1098.   (format nil #+DEUTSCH "Cursor zu Marke ~D"
  1099.               #+ENGLISH "cursor to mark ~D"
  1100.               n
  1101. ) )
  1102.  
  1103. ;-------------------------------------------------------------------------------
  1104.  
  1105. ;; Region (start-lin start-col end-lin end-col) = Der Textbereich
  1106. ;; von (make-mark start-lin start-col) bis (make-mark end-lin end-col).
  1107.  
  1108. ;; Eine linelist ist eine umgedrehte nichtleere Liste von Zeilen, die keine
  1109. ;; Newlines enthalten und zwischen denen jeweils ein Newline zu denken ist:
  1110. ;; (stringn ... string0) mit n>=0 steht für den String
  1111. ;; (string-concat string0 newline-as-string ... newline-as-string stringn).
  1112.  
  1113. (defconstant newline-as-string (string #\Newline))
  1114.  
  1115. ;; Eine Region in eine Liste von Zeilen umwandeln
  1116. (defun region-to-linelist (screen start-lin start-col end-lin end-col)
  1117.   (let ((text (screen-text screen))
  1118.         (linelist '()))
  1119.     (if (eql start-lin end-lin)
  1120.       (push (subseq (aref text start-lin) start-col end-col) linelist)
  1121.       (progn
  1122.         (push (subseq (aref text start-lin) start-col) linelist)
  1123.         (do ((index (1+ start-lin) (1+ index)))
  1124.             ((eql index end-lin))
  1125.           (push (copy-seq (aref text index)) linelist)
  1126.         )
  1127.         (push (subseq (aref text end-lin) 0 end-col) linelist)
  1128.     ) )
  1129.     linelist
  1130. ) )
  1131.  
  1132. ;; String (der Newlines enthalten kann) in Linelist umwandeln:
  1133. (defun string-to-linelist (string)
  1134.   (let ((nlpos (position #\Newline string)))
  1135.     (if (null nlpos)
  1136.       (list string)
  1137.       (macrolet ((subseq (string a b)
  1138.                    `(make-array (- ,b ,a) :element-type 'string-char
  1139.                       :displaced-to ,string :displaced-index-offset ,a
  1140.                     )
  1141.                 ))
  1142.         (let ((linelist (list (subseq string 0 nlpos))))
  1143.           (loop
  1144.             (let ((pos (1+ nlpos)))
  1145.               (when (null (setq nlpos (position #\Newline string :start pos)))
  1146.                 (push (subseq string pos (length string)) linelist)
  1147.                 (return)
  1148.               )
  1149.               (push (subseq string pos nlpos) linelist)
  1150.           ) )
  1151.           linelist
  1152.       ) )
  1153. ) ) )
  1154.  
  1155. ;-------------------------------------------------------------------------------
  1156.  
  1157. ;;; Löschfunktionen
  1158.  
  1159. ;; delete-char löscht das Zeichen unter dem Cursor und liefert T zurück,
  1160. ;; wenn nicht am Zeilenende gewesen und Zeichen gelöscht, sonst NIL.
  1161. (defun delete-char (screen)
  1162.   #+DEUTSCH "Zeichen unter dem Cursor löschen"
  1163.   #+ENGLISH "delete character at cursor"
  1164.   (let* ((text (screen-text screen))
  1165.          (lin (screen-lin screen))
  1166.          (col (screen-col screen))
  1167.          (line (aref text lin))
  1168.          (line-len (length line))
  1169.         )
  1170.     ;; Am Zeilenende?
  1171.     (when (eql col line-len) (return-from delete-char nil))
  1172.     ;; Zeichen löschen
  1173.     (undo2 (let ((c (aref line col)))
  1174.              #'(lambda () (insert-char screen c) (cursor-left screen))
  1175.     )      )
  1176.     (replace line line :start1 col :start2 (1+ col))
  1177.     (decf (fill-pointer line))
  1178.     ;; Updaten
  1179.     (update-marks screen lin (1+ col) lin col)
  1180.     (refresh-line screen lin col)
  1181. ) )
  1182.  
  1183. ;; combine-lines vereinigt die Cursorzeile mit der folgenden
  1184. ;; liefert T zurück, wenn Cursorzeile nicht die letzte war, sonst NIL.
  1185. (defun combine-lines (screen)
  1186.   #+DEUTSCH "Cursorzeile mit der nächsten vereinigen"
  1187.   #+ENGLISH "combine two lines"
  1188.   (let* ((text (screen-text screen))
  1189.          (lin (screen-lin screen))
  1190.          (lin+1 (1+ lin))
  1191.          (line (aref text lin))
  1192.          (line-len (length line))
  1193.         )
  1194.     ;; Letzte Zeile?
  1195.     (when (eql lin+1 (length text)) (return-from combine-lines nil))
  1196.     ;; Zeilen zusammenhängen
  1197.     (undo2
  1198.       (let ((col (screen-col screen)))
  1199.         #'(lambda ()
  1200.             (set-cursor screen lin line-len)
  1201.             (insert-line screen)
  1202.             (set-cursor screen lin col)
  1203.     ) )   )
  1204.     (let ((second-line (aref text lin+1)))
  1205.       (resize-array line (+ line-len (length second-line)))
  1206.       (replace line second-line :start1 line-len)
  1207.     )
  1208.     ;; Zeilen darunter hinaufschieben
  1209.     (replace text text :start1 lin+1 :start2 (1+ lin+1))
  1210.     (shrink-array text 1)
  1211.     ;; Updaten
  1212.     (update-marks screen lin+1 0 lin line-len)
  1213.     (refresh-screen screen lin lin+1 1)
  1214. ) )
  1215.  
  1216. (defun delete-char-1 (screen)
  1217.   #+DEUTSCH "Zeichen unter dem Cursor löschen, zeilenübergreifend"
  1218.   #+ENGLISH "delete character at cursor, across lines"
  1219.   (or (delete-char screen) (combine-lines screen))
  1220. )
  1221.  
  1222. (defun backspace (screen)
  1223.   #+DEUTSCH "Zeichen links vom Cursor löschen"
  1224.   #+ENGLISH "delete character before cursor"
  1225.   (and (plusp (screen-col screen))
  1226.        (cursor-left screen)
  1227.        (delete-char screen)
  1228. ) )
  1229.  
  1230. (defun backspace-1 (screen)
  1231.   #+DEUTSCH "Zeichen links vom Cursor löschen, zeilenübergreifend"
  1232.   #+ENGLISH "delete character before cursor, across lines"
  1233.   (and (cursor-left screen) (delete-char-1 screen))
  1234. )
  1235.  
  1236. ;; Eine Region löschen
  1237. (defun delete-region (screen start-lin start-col end-lin end-col)
  1238.   (let ((text (screen-text screen)))
  1239.     (undo3 screen)
  1240.     (undo2
  1241.       (let ((linelist (region-to-linelist screen start-lin start-col end-lin end-col)))
  1242.         #'(lambda ()
  1243.             (set-cursor screen start-lin start-col)
  1244.             (insert-linelist screen linelist)
  1245.     ) )   )
  1246.     (cond
  1247.       ((eql start-lin end-lin) ; innerhalb einer Zeile
  1248.         (let ((line (aref text start-lin)))
  1249.           ;; Stück der Zeile löschen
  1250.           (replace line line :start1 start-col :start2 end-col)
  1251.           (decf (fill-pointer line) (- end-col start-col))
  1252.           ;; Updaten
  1253.           (update-marks screen end-lin end-col start-lin start-col)
  1254.           (refresh-line screen start-lin start-col)
  1255.       ) )
  1256.       (t (let* ((line1 (aref text start-lin))
  1257.                 (line2 (aref text end-lin))
  1258.                 (new-size-1 (+ start-col (- (length line2) end-col))))
  1259.            ;; Teile der ersten und letzten Zeile zusammenhängen
  1260.            (resize-array line1 new-size-1)
  1261.            (replace line1 line2 :start1 start-col :start2 end-col)
  1262.            ;; Zeilen dazwischen werden frei
  1263.            ;; Zeilen darunter hochschieben
  1264.            (replace text text :start1 (1+ start-lin) :start2 (1+ end-lin))
  1265.            (shrink-array text (- end-lin start-lin))
  1266.            ;; Updaten
  1267.            (update-marks screen end-lin end-col start-lin start-col)
  1268.            (refresh-screen screen start-lin (1+ start-lin) (- end-lin start-lin))
  1269. ) ) ) )  )
  1270.  
  1271. ;; Eine Zeile löschen (Zeile, in der der Cursor steht)
  1272. (defun delete-line (screen)
  1273.   #+DEUTSCH "Zeile löschen"
  1274.   #+ENGLISH "delete line"
  1275.   (let* ((text (screen-text screen))
  1276.          (lin (screen-lin screen)))
  1277.     (if (eql lin (1- (length text)))
  1278.       (delete-region screen lin 0 lin (length (aref text lin)))
  1279.       (delete-region screen lin 0 (1+ lin) 0)
  1280. ) ) )
  1281.  
  1282. (defun clear-start-of-line (screen)
  1283.   #+DEUTSCH "Vom Zeilenanfang bis Cursorposition löschen"
  1284.   #+ENGLISH "delete part of line left to the cursor"
  1285.   (let ((lin (screen-lin screen))
  1286.         (col (screen-col screen)))
  1287.     (delete-region screen lin 0 lin col)
  1288. ) )
  1289.  
  1290. (defun clear-end-of-line (screen)
  1291.   #+DEUTSCH "Bis zum Zeilenende löschen"
  1292.   #+ENGLISH "delete up to end of line"
  1293.   (let ((text (screen-text screen))
  1294.         (lin (screen-lin screen))
  1295.         (col (screen-col screen)))
  1296.     (delete-region screen lin col lin (length (aref text lin)))
  1297. ) )
  1298.  
  1299. ;-------------------------------------------------------------------------------
  1300.  
  1301. ;;; Einfügefunktionen
  1302.  
  1303. ;; insert-char fügt an der Cursorpos. ein Zeichen ein, Cursor nach rechts,
  1304. ;; liefert T zurück.
  1305. (defun insert-char (screen char)
  1306.   (let* ((text (screen-text screen))
  1307.          (lin (screen-lin screen))
  1308.          (col (screen-col screen))
  1309.          (line (aref text lin))
  1310.          (line-len (length line)))
  1311.     ;; Zeichen einfügen
  1312.     (undo2 #'(lambda () (backspace screen)))
  1313.     (resize-array line (1+ line-len))
  1314.     (replace line line :start1 (1+ col) :start2 col)
  1315.     (setf (aref line col) char)
  1316.     ;; Updaten
  1317.     (update-marks screen lin col lin (1+ col))
  1318.     (refresh-line screen lin col)
  1319. ) )
  1320.  
  1321. ;; An Cursorpos. einen Zeilenumbruch einfügen und Cursor an den Anfang
  1322. ;; der neuen Zeile setzen
  1323. (defun insert-line (screen)
  1324.   #+DEUTSCH "Zeilenumbruch einfügen"
  1325.   #+ENGLISH "begin new line at cursor"
  1326.   (let* ((text (screen-text screen))
  1327.          (lin (screen-lin screen))
  1328.          (lin+1 (1+ lin))
  1329.          (col (screen-col screen))
  1330.          (line (aref text lin)))
  1331.     ;; Neue Zeile einfügen
  1332.     (undo2 #'(lambda () (backspace-1 screen)))
  1333.     (let ((new-line (get-new-line (- (length line) col))))
  1334.       (replace new-line line :start2 col)
  1335.       (setf (fill-pointer line) col)
  1336.       (resize-array text (1+ (length text)))
  1337.       (replace text text :start1 (1+ lin+1) :start2 lin+1)
  1338.       (setf (aref text lin+1) new-line)
  1339.     )
  1340.     ;; Updaten
  1341.     (update-marks screen lin col lin+1 0)
  1342.     (refresh-screen screen lin (1+ lin+1) -1)
  1343. ) )
  1344.  
  1345. ;; Eine Liste von Zeilen in umgekehrter Reihenfolge an Cursorposition einfügen
  1346. (defun insert-linelist (screen linelist)
  1347.   (let ((text (screen-text screen))
  1348.         (lin (screen-lin screen))
  1349.         (col (screen-col screen)))
  1350.     (cond
  1351.       ((null linelist) t)
  1352.       ((null (rest linelist))
  1353.         ;; kein Zeilenumbruch: String in Zeile einbauen
  1354.         (let* ((line (aref text lin))
  1355.                (piece (first linelist))
  1356.                (piece-len (length piece))
  1357.                (new-col (+ col piece-len)))
  1358.           ;; Zeile um piece-len verlängern
  1359.           (resize-array line (+ (length line) piece-len))
  1360.           ;; Platz freimachen
  1361.           (replace line line :start1 new-col :start2 col)
  1362.           ;; und String einkopieren
  1363.           (replace line piece :start1 col)
  1364.           ;; Updaten
  1365.           (update-marks screen lin col lin new-col)
  1366.           (undo2 #'(lambda () (delete-region screen lin col lin new-col)))
  1367.           (refresh-line screen lin col)
  1368.       ) )
  1369.       (t
  1370.         (let* ((nl-count (1- (length linelist)))
  1371.                (last-lin (+ lin nl-count)))
  1372.           ;; Text-Buffer vergrößern
  1373.           (resize-array text (+ (length text) nl-count))
  1374.           ;; Platz freimachen
  1375.           (replace text text :start1 (1+ last-lin) :start2 (1+ lin))
  1376.           ;; und Zeilen einfügen
  1377.           (let* ((line (aref text lin))
  1378.                  (index last-lin)
  1379.                  (last-line (pop linelist))
  1380.                  (last-len (length last-line)))
  1381.             ;; Letzte neue Zeile mit Rest der Cursorzeile verbinden
  1382.             (let ((new-line (get-new-line (+ last-len (- (length line) col)))))
  1383.               (replace new-line last-line)
  1384.               (replace new-line line :start1 last-len :start2 col)
  1385.               (setf (aref text index) new-line)
  1386.             )
  1387.             ;; Die mittleren Zeilen einfügen
  1388.             (loop
  1389.               (when (null (rest linelist)) (return))
  1390.               (decf index)
  1391.               (let* ((curr-line (pop linelist))
  1392.                      (new-line (get-new-line (length curr-line))))
  1393.                 (replace new-line curr-line)
  1394.                 (setf (aref text index) new-line)
  1395.             ) )
  1396.             ;; Cursorzeilenanfang mit erster einzufügender Zeile kombinieren
  1397.             (let ((first-line (first linelist)))
  1398.               (resize-array line (+ col (length first-line)))
  1399.               (replace line first-line :start1 col)
  1400.             )
  1401.             ;; Updaten
  1402.             (update-marks screen lin col last-lin last-len)
  1403.             (undo2 #'(lambda () (delete-region screen lin col last-lin last-len)))
  1404.             (refresh-screen screen lin (1+ last-lin) (- nl-count))
  1405. ) ) ) ) ) )
  1406.  
  1407. ;; An Cursorpos. einen String einfügen und Cursor an das Ende des eingefügten
  1408. ;; Textes setzen
  1409. (defun insert-string (screen string)
  1410.   (insert-linelist screen (string-to-linelist string))
  1411. )
  1412.  
  1413. ;-------------------------------------------------------------------------------
  1414.  
  1415. ;; Eine Region auf einen Stream schreiben
  1416. (defun write-region (screen start-lin start-col end-lin end-col stream)
  1417.   (let ((text (screen-text screen)))
  1418.     (if (eql start-lin end-lin)
  1419.       (write-string (aref text start-lin) stream :start start-col :end end-col)
  1420.       (progn
  1421.         (write-line (aref text start-lin) stream :start start-col)
  1422.         (do ((index (1+ start-lin) (1+ index)))
  1423.             ((eql index end-lin))
  1424.           (write-line (aref text index) stream)
  1425.         )
  1426.         (write-string (aref text end-lin) stream :end end-col)
  1427.   ) ) )
  1428.   t
  1429. )
  1430.  
  1431. ;; Von einem Stream lesen und einfügen an Cursorposition
  1432. (defun insert-stream (screen stream)
  1433.   (insert-linelist screen
  1434.     (let ((eof "EOF")
  1435.           (linelist '()))
  1436.       (loop
  1437.         (multiple-value-bind (line eof-reached) (read-line stream nil eof)
  1438.           (when (eq line eof) (push "" linelist) (return))
  1439.           (push line linelist)
  1440.           (when eof-reached (return))
  1441.       ) )
  1442.       linelist
  1443. ) ) )
  1444.  
  1445. ;-------------------------------------------------------------------------------
  1446.  
  1447. ;;; Block
  1448.  
  1449. (defun cursor-to-start-of-block (screen)
  1450.   #+DEUTSCH "Cursor zum Blockanfang"
  1451.   #+ENGLISH "cursor to start of block"
  1452.   (let* ((marks (screen-marks screen))
  1453.          (mark1 (aref marks 0))
  1454.          (mark2 (aref marks 1)))
  1455.     (and mark1 mark2
  1456.          (progn (undo3 screen)
  1457.                 (set-cursor screen (mark-lin mark1) (mark-col mark1))
  1458. ) ) )    )
  1459.  
  1460. (defun cursor-to-end-of-block (screen)
  1461.   #+DEUTSCH "Cursor zum Blockende"
  1462.   #+ENGLISH "cursor to end of block"
  1463.   (let* ((marks (screen-marks screen))
  1464.          (mark1 (aref marks 0))
  1465.          (mark2 (aref marks 1)))
  1466.     (and mark1 mark2
  1467.          (progn (undo3 screen)
  1468.                 (set-cursor screen (mark-lin mark2) (mark-col mark2))
  1469. ) ) )    )
  1470.  
  1471. (defun set-block-start (screen &optional (lin (screen-lin screen))
  1472.                                          (col (screen-col screen)) )
  1473.   #+DEUTSCH "Blockanfang setzen"
  1474.   #+ENGLISH "set block start"
  1475.   (undo-blockmarks screen)
  1476.   (let* ((marks (screen-marks screen))
  1477.          (mark1 (aref marks 0))
  1478.          (mark2 (aref marks 1))
  1479.          (end-lin (and mark2 (mark-lin mark2)))
  1480.          (end-col (and mark2 (mark-col mark2)))
  1481.          (start-lin (if mark1 (min (mark-lin mark1) lin) lin)))
  1482.     (unless ; existiert mark2 und liegt hinter (lin,col) ?
  1483.             (and mark2 (or (> end-lin lin)
  1484.                            (and (= end-lin lin) (>= end-col col))
  1485.             )          )
  1486.       (let ((text (screen-text screen)))
  1487.         (setq end-lin (1- (length text)))
  1488.         (setq end-col (length (aref text end-lin)))
  1489.         (setf (aref marks 1) (make-mark end-lin end-col))
  1490.     ) )
  1491.     (setf (aref marks 0) (make-mark lin col))
  1492.     (refresh-screen screen start-lin (1+ end-lin))
  1493. ) )
  1494.  
  1495. (defun set-block-end (screen &optional (lin (screen-lin screen))
  1496.                                        (col (screen-col screen)) )
  1497.   #+DEUTSCH "Blockende setzen"
  1498.   #+ENGLISH "set block end"
  1499.   (undo-blockmarks screen)
  1500.   (let* ((marks (screen-marks screen))
  1501.          (mark1 (aref marks 0))
  1502.          (mark2 (aref marks 1))
  1503.          (start-lin (and mark1 (mark-lin mark1)))
  1504.          (start-col (and mark1 (mark-col mark1)))
  1505.          (end-lin (if mark2 (max (mark-lin mark2) lin) lin)))
  1506.     (unless ; existiert mark1 und liegt vor (lin,col) ?
  1507.             (and mark1 (or (< start-lin lin)
  1508.                            (and (= start-lin lin) (<= start-col col))
  1509.             )          )
  1510.       (setq start-lin 0)
  1511.       (setq start-col 0)
  1512.       (setf (aref marks 0) (make-mark start-lin start-col))
  1513.     )
  1514.     (setf (aref marks 1) (make-mark lin col))
  1515.     (refresh-screen screen start-lin (1+ end-lin))
  1516. ) )
  1517.  
  1518. (defun hide-block (screen)
  1519.   #+DEUTSCH "Block demarkieren"
  1520.   #+ENGLISH "remove block marks"
  1521.   (undo-blockmarks screen)
  1522.   (let* ((marks (screen-marks screen))
  1523.          (mark1 (aref marks 0))
  1524.          (mark2 (aref marks 1)))
  1525.     (setf (aref marks 0) nil (aref marks 1) nil)
  1526.     (and mark1 mark2
  1527.          (refresh-screen screen (mark-lin mark1) (1+ (mark-lin mark2)))
  1528. ) ) )
  1529.  
  1530. (defun undo-blockmarks (screen)
  1531.   (let* ((marks (screen-marks screen))
  1532.          (mark1 (aref marks 0))
  1533.          (mark2 (aref marks 1)))
  1534.     (when mark2
  1535.       (undo2 (let ((lin (mark-lin mark2)) (col (mark-col mark2)))
  1536.                #'(lambda () (set-block-end screen lin col))
  1537.     ) )      )
  1538.     (when mark1
  1539.       (undo2 (let ((lin (mark-lin mark1)) (col (mark-col mark1)))
  1540.                #'(lambda () (set-block-start screen lin col))
  1541.     ) )      )
  1542.     (undo2 #'(lambda () (hide-block screen)))
  1543. ) )
  1544.  
  1545. (defun mark-region (screen lin1 col1 lin2 col2)
  1546.   (and lin1
  1547.        (let* ((marks (screen-marks screen))
  1548.               (mark1 (aref marks 0))
  1549.               (mark2 (aref marks 1)))
  1550.          (setf (aref marks 0) (make-mark lin1 col1)
  1551.                (aref marks 1) (make-mark lin2 col2)
  1552.          )
  1553.          (when (and mark1 mark2)
  1554.            (setq lin1 (min lin1 (mark-lin mark1))
  1555.                  lin2 (max lin2 (mark-lin mark2))
  1556.          ) )
  1557.          (refresh-screen screen lin1 (1+ lin2))
  1558. ) )    )
  1559.  
  1560. (defun get-block (screen)
  1561.   (let* ((marks (screen-marks screen))
  1562.          (mark1 (aref marks 0))
  1563.          (mark2 (aref marks 1)))
  1564.     (if (and mark1 mark2)
  1565.       (values (mark-lin mark1) (mark-col mark1)
  1566.               (mark-lin mark2) (mark-col mark2)
  1567.       )
  1568.       (values nil nil nil nil)
  1569. ) ) )
  1570.  
  1571. (defun delete-block (screen)
  1572.   #+DEUTSCH "Block löschen"
  1573.   #+ENGLISH "delete block"
  1574.   (let* ((marks (screen-marks screen))
  1575.          (mark1 (aref marks 0))
  1576.          (mark2 (aref marks 1)))
  1577.     (unless (and mark1 mark2) (return-from delete-block nil))
  1578.     (undo-blockmarks screen)
  1579.     (setf (aref marks 0) nil (aref marks 1) nil)
  1580.     (delete-region screen (mark-lin mark1) (mark-col mark1)
  1581.                           (mark-lin mark2) (mark-col mark2)
  1582. ) ) )
  1583.  
  1584. ; Undo ab hier implementieren??
  1585.  
  1586. (defun move-block (screen) ; Block an Cursorposition verschieben
  1587.   #+DEUTSCH "Block an Cursorposition verschieben"
  1588.   #+ENGLISH "move block to cursor position"
  1589.   (let* ((marks (screen-marks screen))
  1590.          (mark1 (aref marks 0))
  1591.          (mark2 (aref marks 1)))
  1592.     (unless (and mark1 mark2) (return-from move-block nil))
  1593.     (let* ((lin1 (mark-lin mark1))
  1594.            (col1 (mark-col mark1))
  1595.            (lin2 (mark-lin mark2))
  1596.            (col2 (mark-col mark2))
  1597.            ;; Block in Zeilenliste packen:
  1598.            (linelist (region-to-linelist screen lin1 col1 lin2 col2)))
  1599.       ;; und löschen:
  1600.       (delete-region screen lin1 col1 lin2 col2)
  1601.       (let ((lin (screen-lin screen)) ; Cursorpos. merken
  1602.             (col (screen-col screen)))
  1603.         (insert-linelist screen linelist) ; Block an Cursorpos. einfügen
  1604.         (setf (mark-lin mark1) lin    ; alte Cursorpos. = Anfang
  1605.               (mark-col mark1) col
  1606.         )
  1607.         (setf (mark-lin mark2) (screen-lin screen) ; neue Cursorpos. = Ende
  1608.               (mark-col mark2) (screen-col screen)
  1609.         )
  1610.         (refresh-screen screen lin (1+ (screen-lin screen)))
  1611. ) ) ) )
  1612.  
  1613. (defun copy-block (screen) ; Block kopieren (ohne Marken)
  1614.   #+DEUTSCH "Block an Cursorposition kopieren"
  1615.   #+ENGLISH "copy block to cursor position"
  1616.   (multiple-value-bind (lin1 col1 lin2 col2) (get-block screen)
  1617.     (and lin1
  1618.          (insert-linelist screen
  1619.                           (region-to-linelist screen lin1 col1 lin2 col2)
  1620. ) ) )    )
  1621.  
  1622. ;-------------------------------------------------------------------------------
  1623.  
  1624. ;;; Block und Cut-and-Paste-Buffer
  1625.  
  1626. ;; Enthält umgedrehte Zeilenliste
  1627. (defvar *cut-and-paste-buffer* '())
  1628.  
  1629. (defun copy-block-buffer (screen)
  1630.   #+DEUTSCH "Block in Cut-and-Paste-Buffer übertragen"
  1631.   #+ENGLISH "copy block into cut-and-paste buffer"
  1632.   (multiple-value-bind (lin1 col1 lin2 col2) (get-block screen)
  1633.     (and lin1
  1634.          (progn
  1635.            (setq *cut-and-paste-buffer*
  1636.                  (region-to-linelist screen lin1 col1 lin2 col2)
  1637.            )
  1638.            t
  1639. ) ) )    )
  1640.  
  1641. (defun delete-block-buffer (screen)
  1642.   #+DEUTSCH "Block löschen und in Cut-and-Paste-Buffer übertragen"
  1643.   #+ENGLISH "yank block into cut-and-paste buffer"
  1644.   (let* ((marks (screen-marks screen))
  1645.          (mark1 (aref marks 0))
  1646.          (mark2 (aref marks 1)))
  1647.     (and mark1 mark2
  1648.          (progn
  1649.            (setf (aref marks 0) nil (aref marks 1) nil)
  1650.            (let ((lin1 (mark-lin mark1))
  1651.                  (col1 (mark-col mark1))
  1652.                  (lin2 (mark-lin mark2))
  1653.                  (col2 (mark-col mark2)))
  1654.              (setq *cut-and-paste-buffer*
  1655.                    (region-to-linelist screen lin1 col1 lin2 col2)
  1656.              )
  1657.              (delete-region screen lin1 col1 lin2 col2)
  1658. ) ) )    ) )
  1659.  
  1660. (defun paste-buffer (screen)
  1661.   #+DEUTSCH "Inhalt des Cut-and-Paste-Buffer einfügen"
  1662.   #+ENGLISH "insert cut-and-paste buffer contents"
  1663.   (insert-linelist screen *cut-and-paste-buffer*)
  1664. )
  1665.  
  1666. ;-------------------------------------------------------------------------------
  1667.  
  1668. ;; Macro zum Auswerten von Formen, wobei Fehler abgefangen werden und den Wert
  1669. ;; von errorval liefern
  1670. (defconstant errorval "ERROR")
  1671.  
  1672. (defmacro with-ignored-errors (&body body)
  1673.   (let ((blockvar (gensym)))
  1674.     `(BLOCK ,blockvar
  1675.        (LET ((*ERROR-HANDLER*
  1676.                #'(LAMBDA (&REST ARGS)
  1677.                    (DECLARE (IGNORE ARGS))
  1678.                    (RETURN-FROM ,blockvar ERRORVAL)
  1679.             ))   )
  1680.          ,@body
  1681.      ) )
  1682. ) )
  1683.  
  1684. ;; Dito, mit Ausgabe der Fehlermeldung auf *error-output*
  1685. (defmacro with-trapped-errors (&body body)
  1686.   (let ((blockvar (gensym)))
  1687.     `(BLOCK ,blockvar
  1688.        (LET ((*ERROR-HANDLER*
  1689.                #'(LAMBDA (CONTINUE ERRSTR &REST ARGS)
  1690.                    (DECLARE (IGNORE CONTINUE)) ; vorläufig
  1691.                    #-CLISP1 (FRESH-LINE *ERROR-OUTPUT*)
  1692.                    #-CLISP1 (APPLY #'FORMAT *ERROR-OUTPUT* ERRSTR ARGS)
  1693.                    #+CLISP1 ; Workaround um ein Bug in ADJUST-ARRAY, das in
  1694.                             ; Erscheinung tritt, wenn der Speicher voll ist:
  1695.                             (LET ((STREAM *ERROR-OUTPUT*))
  1696.                               (MULTIPLE-VALUE-BIND (NEED ROOM) (ROOM)
  1697.                                 (DECLARE (IGNORE NEED))
  1698.                                 (WHEN (< ROOM 1024)
  1699.                                   (GC)
  1700.                                   (MULTIPLE-VALUE-BIND (NEED ROOM) (ROOM)
  1701.                                     (DECLARE (IGNORE NEED))
  1702.                                     (WHEN (< ROOM 1024)
  1703.                                       (SETQ STREAM *DEBUG-IO*)
  1704.                               ) ) ) )
  1705.                               (FRESH-LINE STREAM)
  1706.                               (APPLY #'FORMAT STREAM ERRSTR ARGS)
  1707.                             )
  1708.                    (RETURN-FROM ,blockvar ERRORVAL)
  1709.             ))  )
  1710.          ,@body
  1711.      ) )
  1712. ) )
  1713.  
  1714. ;===========================================================================
  1715. ;                        E D I T O R - T O P L E V E L
  1716. ;===========================================================================
  1717.  
  1718. ;; Eine key-table ist eine Hashtable  char -> fun,  die Tastendrücken Prozeduren
  1719. ;; zuordnet. fun ist eine Funktion von einem screen-Argument und gibt einen
  1720. ;; booleschen Wert zurück: t bei Erfolg, nil bei Mißerfolg
  1721.  
  1722. ;; Full-Screen-Tabelle
  1723. (defconstant full-table (make-hash-table :test #'eql))
  1724. ;; Read-Only-Tabelle
  1725. (defconstant half-table (make-hash-table :test #'eql))
  1726. ;; Tabelle für Line-Edit
  1727. (defconstant line-edit-table (make-hash-table :test #'eql))
  1728.  
  1729. ;; Control-Table-Default: Nur Escape
  1730. (defconstant null-table (make-hash-table :test #'eql))
  1731. (setf (gethash #\Escape null-table) '(:LEAVE))
  1732. ;; Volle Control-Table des Editors
  1733. (defconstant control-table (make-hash-table :test #'eql))
  1734.  
  1735. (defconstant docstrings-table (make-hash-table :test #'eql))
  1736.  
  1737. (defun bind-key (keys flag fun &optional (docstring nil))
  1738.   (unless (listp keys) (setq keys (list keys)))
  1739.   (when (and (symbolp fun) (not (null fun)))
  1740.     (unless docstring (setq docstring (documentation fun 'function)))
  1741.     (setq fun (symbol-function fun))
  1742.   )
  1743.   (let ((tables
  1744.           (case flag
  1745.             (:CONTROL (list control-table))
  1746.             (:ALL (list full-table half-table line-edit-table))
  1747.             (:WRITABLE (list full-table line-edit-table))
  1748.             (:MULTILINE (list full-table half-table))
  1749.             (:AND-WRITABLE-MULTILINE (list full-table))
  1750.             (:AND-WRITABLE-NOT-MULTILINE (list line-edit-table))
  1751.        )) )
  1752.     (dolist (key keys)
  1753.       (dolist (table tables)
  1754.         (setf (gethash key table) fun)
  1755.       )
  1756.       (when docstring
  1757.         (setf (gethash key docstrings-table) docstring)
  1758.     ) )
  1759. ) )
  1760.  
  1761. ;; ob der Editor aktiv ist
  1762. (defvar *editor-active* nil)
  1763. ;; Vektor aller Screens des Editors
  1764. (defvar *edit-screens* (make-array 13 :initial-element nil))
  1765. ;; Vektor dazugehöriger Pathnames bzw. Conses (package . env)
  1766. (defvar *screen-paths* (make-array 13 :initial-element nil))
  1767. ;; momentan aktiver Screen
  1768. (defvar *active-screen*)
  1769.  
  1770. ;; Fenster für Fehlermeldungen
  1771. (defvar error-screen)
  1772. ;; Fenster für Traces
  1773. (defvar trace-screen)
  1774. ;; Hilfefenster, enthält Tastenzuordnungen
  1775. (defvar help-screen)
  1776. ;; Hauptfenster (ganzer Bildschirm)
  1777. (defvar main-screen)
  1778.  
  1779. ;; Editor
  1780. (defun edit (&optional start-command)
  1781.   (if *editor-active*
  1782.     (throw 'editor-active start-command) ; Editor nicht rekursiv aufrufen!
  1783.     (with-keyboard
  1784.       (with-window
  1785.         (unless (boundp 'main-screen)
  1786.           (setf (aref *edit-screens* 0)
  1787.             (setf main-screen (make-screen))
  1788.         ) )
  1789.         (unless (boundp 'error-screen)
  1790.           (setf (aref *edit-screens* 10)
  1791.             (setf error-screen
  1792.               (make-screen :title " Errors: " :height 10 :width 50
  1793.                            :top-lin 2 :left-col (- global-screen-width 53)
  1794.         ) ) ) )
  1795.         (unless (boundp 'trace-screen)
  1796.           (setf (aref *edit-screens* 11)
  1797.             (setf trace-screen
  1798.               (make-screen :title " Trace: " :height 15 :width 70
  1799.                            :top-lin 8 :left-col 3
  1800.         ) ) ) )
  1801.         (unless (boundp 'help-screen)
  1802.           (setf (aref *edit-screens* 12)
  1803.             (setf help-screen
  1804.               (make-screen :title #+DEUTSCH " Tastenzuordnung "
  1805.                                   #+ENGLISH " Key bindings "
  1806.                            :height 15 :width 78
  1807.           ) ) )
  1808.           (insert-linelist help-screen
  1809.             (reverse
  1810.               '(" ==========================================================================="
  1811.                 #+DEUTSCH "                         T A S T E N B E L E G U N G"
  1812.                 #+ENGLISH "                           K E Y   B I N D I N G S"
  1813.                 " ==========================================================================="
  1814.                 ""
  1815.                 ""
  1816.           ) )  )
  1817.           ;(maphash #'(lambda (key docstring)
  1818.           ;             (insert-string help-screen (format nil "~:@C~25T --> ~A~%" key docstring))
  1819.           ;             (line-up help-screen)
  1820.           ;           )
  1821.           ;         docstrings-table
  1822.           ;)
  1823.           ; Das ist reichlich langsam! Geht's so schneller?
  1824.           (insert-linelist help-screen
  1825.             (reverse
  1826.               (let ((lines '()))
  1827.                 (maphash #'(lambda (key docstring)
  1828.                              (push (format nil "~:@C~25T --> ~A" key docstring) lines)
  1829.                            )
  1830.                          docstrings-table
  1831.                 )
  1832.                 lines
  1833.           ) ) )
  1834.           (set-cursor help-screen 0 0)
  1835.         )
  1836.         (unless (boundp '*active-screen*)
  1837.           (setf *active-screen* 0)
  1838.         )
  1839.         (unwind-protect
  1840.           (block editor
  1841.             ; Ab hier kann der Editor als aktiv angesehen werden.
  1842.             ; Schleife zum Abfangen und Behandeln der Kommandos:
  1843.             (flet ((handle-command (command &rest args)
  1844.                      (catch 'handle-command
  1845.                        (case command
  1846.                          (:LEAVE (return-from editor))
  1847.                          (:ERROR (setq *active-screen* 10))
  1848.                          (:TRACE (setq *active-screen* 11))
  1849.                          (:HELP (setq *active-screen* 12))
  1850.                          (:TOP
  1851.                            (if (null (aref *edit-screens* (first args)))
  1852.                              (bell)
  1853.                              (setq *active-screen* (first args))
  1854.                          ) )
  1855.                          (:HIDE
  1856.                            (if (null (aref *edit-screens* (first args)))
  1857.                              (bell)
  1858.                              (let ((new-active
  1859.                                      (hide-screen (aref *edit-screens* (first args)))
  1860.                                   ))
  1861.                                (setq *active-screen*
  1862.                                      (or (and (not (null new-active))
  1863.                                               (position new-active *edit-screens*
  1864.                                                         :test #'eq
  1865.                                          )    )
  1866.                                          0
  1867.                          ) ) ) )     )
  1868.                          (:DELETE
  1869.                            (cond
  1870.                              ((< 0 *active-screen* 10)
  1871.                                (let ((new-active
  1872.                                        (hide-screen (aref *edit-screens* *active-screen*))
  1873.                                     ))
  1874.                                  (setf (aref *edit-screens* *active-screen*) nil)
  1875.                                  (setf (aref *screen-paths* *active-screen*) nil)
  1876.                                  (setq *active-screen*
  1877.                                        (or (and (not (null new-active))
  1878.                                                 (position new-active *edit-screens*
  1879.                                                           :test #'eq
  1880.                                            )    )
  1881.                                            0
  1882.                              ) ) )     )
  1883.                              (t (bell))
  1884.                          ) )
  1885.                          (:SAVE
  1886.                            (unless (aref *screen-paths* *active-screen*)
  1887.                              (setf (aref *screen-paths* *active-screen*) (get-save-path))
  1888.                            )
  1889.                            (let ((screen (aref *edit-screens* *active-screen*))
  1890.                                  (destination (aref *screen-paths* *active-screen*)))
  1891.                              (if (atom destination) ; Pathname oder Cons?
  1892.                                (screen-to-file screen destination)
  1893.                                ; Load vom Screen:
  1894.                                (let ((f (make-read-from-screen-stream screen 0 0))
  1895.                                      (*package* (car destination)) ; *PACKAGE* binden
  1896.                                      (env (cdr destination)) ; Evaluator-Environment
  1897.                                      (end-of-file "EOF")) ; einmaliges Objekt
  1898.                                  (loop
  1899.                                    (let ((obj (read f nil end-of-file)))
  1900.                                      (when (eql obj end-of-file) (return))
  1901.                                      (evalhook obj nil nil env)
  1902.                                ) ) )
  1903.                          ) ) )
  1904.                          (:SAVE-AS
  1905.                            (screen-to-file (aref *edit-screens* *active-screen*) (get-save-path))
  1906.                          )
  1907.                          (:LOAD ; (:LOAD path)
  1908.                            (let ((new-active (position nil *edit-screens*)))
  1909.                              (if (null new-active)
  1910.                                (bell)
  1911.                                (let ((path
  1912.                                        (if args
  1913.                                          (first args)
  1914.                                          (line-edit #+DEUTSCH " Lade: "
  1915.                                                     #+ENGLISH " File to load: "
  1916.                                     )) ) )
  1917.                                  (setq path (with-ignored-errors (pathname path)))
  1918.                                  (if (eq path errorval)
  1919.                                    (bell)
  1920.                                    (progn
  1921.                                      (setf (aref *edit-screens* new-active)
  1922.                                            (file-to-screen path new-active)
  1923.                                      )
  1924.                                      (setf (aref *screen-paths* new-active) path)
  1925.                                      (setq *active-screen* new-active)
  1926.                          ) ) ) ) ) )
  1927.                          (:FORM ; (:FORM sym package env string)
  1928.                            (let ((new-active (position nil *edit-screens*)))
  1929.                              (if (null new-active)
  1930.                                (bell)
  1931.                                (let ((screen (make-screen
  1932.                                                :title (format nil " ~A " (first args))
  1933.                                                :top-lin new-active :width 78 :height 13
  1934.                                     ))       )
  1935.                                  (insert-string screen (fourth args))
  1936.                                  (insert-line screen)
  1937.                                  (set-cursor screen 0 0)
  1938.                                  (setf (aref *edit-screens* new-active) screen)
  1939.                                  (setf (aref *screen-paths* new-active) (cons (second args) (third args)))
  1940.                                  (setq *active-screen* new-active)
  1941.                          ) ) ) )
  1942.                          (t (bell))
  1943.                   )) ) )
  1944.               (loop
  1945.                 (setq start-command
  1946.                   (catch 'editor-active
  1947.                     (let ((*editor-active* t))
  1948.                       ; nächstes Kommando holen und abarbeiten:
  1949.                       (apply #'handle-command
  1950.                         (or start-command
  1951.                             (edit1 (aref *edit-screens* *active-screen*)
  1952.                                    control-table
  1953.                                    (if (< *active-screen* 10) full-table half-table)
  1954.                       ) )   )
  1955.                       nil
  1956.               ) ) ) )
  1957.           ) )
  1958.           (doseq (screen *edit-screens*)
  1959.             (unless (null screen) (hide-screen screen))
  1960.           )
  1961.           (screen-clear-screen)
  1962. ) ) ) ) )
  1963.  
  1964. #|
  1965. ;; Editierfunktion: Editiere ein Fenster
  1966. (defun edit-screen (screen &optional (key-table-1 null-table)
  1967.                                      (key-table-2 full-table)
  1968.                    )
  1969.   (edit1 screen key-table-1 key-table-2)
  1970. )
  1971. |#
  1972.  
  1973. ;; Defaultfunktion für Tastenzuordnung: Nichts tun, Mißerfolg melden (= NIL)
  1974. (defun return-nil (&rest args)
  1975.   (declare (ignore args))
  1976.   nil
  1977. )
  1978.  
  1979. ;; Editier-Hauptschleife
  1980. (defun edit1 (screen key-table-1 key-table-2)
  1981.   (activate-screen screen)
  1982.   (catch 'edit
  1983.     (flet ((read-edit-command ()
  1984.              (prog2
  1985.                (set-cursor-visible screen) ; Cursor ins Fenster und einschalten
  1986.                (read-char *keyboard-input*)
  1987.                (screen-cursor-off) ; Cursor abschalten
  1988.            ) )
  1989.            (execute-edit-command (char)
  1990.              (catch 'handle-command
  1991.                (if (and (string-char-p char)
  1992.                         (char>= char #\Space)
  1993.                         (not (char= char #\Rubout))
  1994.                    )
  1995.                  ;; normales Zeichen: unter Key :string-char nachschauen
  1996.                  (or (funcall (gethash :string-char key-table-2 #'return-nil)
  1997.                               screen char
  1998.                      )
  1999.                      (bell)
  2000.                  )
  2001.                  ;; sonst: erst Bedeutung für Editier-Ende nachsehen
  2002.                  (multiple-value-bind (return-value presentp)
  2003.                      (gethash char key-table-1)
  2004.                    (when presentp (throw 'edit return-value))
  2005.                    ;; sonst Editierfunktion ausführen
  2006.                    (or (funcall (gethash char key-table-2 #'return-nil) screen)
  2007.                        (bell) ; falls undefiniert oder ohne Erfolg
  2008.           )) ) ) ) )
  2009.       (loop (execute-edit-command (read-edit-command)))
  2010. ) ) )
  2011.  
  2012. ;; Einen Pfad fürs Abspeichern erfragen
  2013. (defun get-save-path ()
  2014.   (let (path)
  2015.     (loop
  2016.       (setq path (line-edit #+DEUTSCH " Abspeichern als: "
  2017.                             #+ENGLISH " Save as: "
  2018.       )          )
  2019.       (setq path (with-ignored-errors (pathname path)))
  2020.       (unless (eq path errorval) (return))
  2021.       (bell)
  2022.     )
  2023.     path
  2024. ) )
  2025.  
  2026. ;; Eine Zeile editieren und Ergebnis zurückliefern
  2027. (defun line-edit (title &optional (old ""))
  2028.   (let ((query-screen (make-screen :height 1 :width 40 :title title)))
  2029.     (insert-string query-screen old)
  2030.     (let ((command
  2031.             (edit1 query-screen null-table line-edit-table)
  2032.          ))
  2033.       (hide-screen query-screen)
  2034.       (when (eq (first command) ':LEAVE) ; bei Escape
  2035.         (throw 'handle-command nil) ; aktuelles Kommando abbrechen
  2036.       )
  2037.       (copy-seq (aref (screen-text query-screen) 0))
  2038. ) ) )
  2039.  
  2040. ;===========================================================================
  2041. ;                      A R B E I T E N   M I T   F I L E S
  2042. ;===========================================================================
  2043.  
  2044. ;; Ein File in einen Screen einlesen, leerer Screen, falls File nicht vorhanden
  2045. (defun file-to-screen (path number) ; 1 <= number <= 9
  2046.   (let ((screen (make-screen
  2047.                   :title (format nil " ~A " (enough-namestring path))
  2048.                   :top-lin number :width 78 :height 13
  2049.        ))       )
  2050.     (when (probe-file path)
  2051.       (with-open-file (s path :direction :input) (insert-stream screen s))
  2052.       (set-cursor screen 0 0)
  2053.     )
  2054.     screen
  2055. ) )
  2056.  
  2057. ;; Screen in ein File schreiben
  2058. (defun screen-to-file (screen file)
  2059.   (let* ((text (screen-text screen))
  2060.          (text-len-1 (1- (length text)))
  2061.         )
  2062.     (with-open-file (s file :direction :output :if-exists :rename)
  2063.       (write-region screen 0 0 text-len-1 (length (aref text text-len-1)) s)
  2064.   ) )
  2065.   t
  2066. )
  2067.  
  2068. ;===========================================================================
  2069. ;  E I N Z E L F U N K T I O N E N   F Ü R   T A S T E N Z U O R D N U N G
  2070. ;===========================================================================
  2071.  
  2072. (defun finish (screen)
  2073.   (declare (ignore screen))
  2074.   (throw 'edit '(:FINISH))
  2075. )
  2076.  
  2077. ;; Erzeuge einen Stream, der aus dem screen ab Position lin1,col1 bis Position
  2078. ;; lin2,col2 (optional, Default Textende) liest;
  2079. ;; Zweiter Wert ist eine Funktion von 0 Argumenten, die die Position, bis zu
  2080. ;; der gelesen wurde, angibt (als (values lin col)).
  2081. ;; Solange der Stream verwendet wird, sollten Modifikationen des screen
  2082. ;; unterbleiben.
  2083. (defun make-read-from-screen-stream (screen lin1 col1 &optional lin2 col2)
  2084.   (let ((text (screen-text screen)))
  2085.     (unless lin2 (setq lin2 (1- (length text))))
  2086.     (unless col2 (setq col2 (length (aref text lin2))))
  2087.     ; Region von (lin1,col1) bis (lin2,col2) lesen:
  2088.     (let* ((lastlin nil)
  2089.            (lastcol nil)
  2090.            (stream
  2091.              (make-buffered-input-stream
  2092.                ; Funktion, die abwechselnd ein Textstück und ein Newline
  2093.                ; durchreicht, bis die Region zu Ende ist:
  2094.                #'(lambda ()
  2095.                    ; lin1, col1 laufen.
  2096.                    (if (or (> lin1 lin2) (and (= lin1 lin2) (>= col1 col2)))
  2097.                      nil ; Ende der Region
  2098.                      (let ((line (aref text lin1)))
  2099.                        (setq lastlin lin1 lastcol col1)
  2100.                        (if (>= col1 (length line)) ; am Zeilenende?
  2101.                          ; Zeilenende: Newline durchreichen
  2102.                          (progn
  2103.                            (incf lin1) (setq col1 0)
  2104.                            (values newline-as-string 0 1)
  2105.                          )
  2106.                          ; sonst: Zeile bzw. Zeilenrest durchreichen
  2107.                          (values line col1 (setq col1 (length line)))
  2108.                  ) ) ) )
  2109.                nil
  2110.           )) )
  2111.       (values
  2112.         stream
  2113.         ; Funktion, die die Position im Screen liefert, an der der Stream
  2114.         ; sich gerade befindet:
  2115.         ; Stream hat einen String und einen internen Index.
  2116.         ; Zustand 1 (sofort nach Initialisierung):
  2117.         ;           String = "", Index = 0, liefere (lin1,col1).
  2118.         ; Zustand 2 (nach Zeilen-Übergabe):
  2119.         ;           String = Zeile, lastcol <= index <= col1, lastlin = lin1,
  2120.         ;           liefere (lin1,index).
  2121.         ; Zustand 3 (nach Newline-Übergabe):
  2122.         ;           String = Newline-as-String, col1 = 0,
  2123.         ;           bei Index = 0 liefere (lastlin,lastcol),
  2124.         ;           bei Index = 1 liefere (lin1,col1).
  2125.         #'(lambda ()
  2126.             (let ((index (sys::buffered-input-stream-index stream)))
  2127.               (if (eql index 0)
  2128.                 ; Zustand 1 oder 2 oder 3a
  2129.                 (values lastlin lastcol)
  2130.                 ; Zustand 2 oder 3b
  2131.                 (values lin1 (min index col1))
  2132.           ) ) )
  2133.       )
  2134. ) ) )
  2135.  
  2136. ;; Erzeuge einen Stream, der ab Cursorposition in den screen schreibt
  2137. (defun make-write-to-screen-stream (screen)
  2138.   (make-buffered-output-stream
  2139.     #'(lambda (string) (insert-string screen string))
  2140.     (screen-col screen)
  2141. ) )
  2142.  
  2143. ;; Erzeuge einen Stream, der ab Textende in den screen schreibt und ein
  2144. ;; Flag setzt, wenn etwas geschrieben wurde
  2145. (defmacro make-write-to-screen-stream-with-flag (screenform flagvar)
  2146.   (let ((stringvar (gensym)) (screenvar (gensym)))
  2147.     `(LET ((,screenvar ,screenform))
  2148.        (CURSOR-TO-END-OF-TEXT ,screenvar)
  2149.        (MAKE-BUFFERED-OUTPUT-STREAM
  2150.          #'(LAMBDA (,stringvar)
  2151.              (INSERT-STRING ,screenvar ,stringvar)
  2152.              (WHEN (PLUSP (LENGTH ,stringvar)) (SETQ ,flagvar T))
  2153.            )
  2154.          (SCREEN-COL ,screenvar)
  2155. ) )  ) )
  2156.  
  2157. ;; Lies ein Objekt aus dem angegebenen Bereich, werte es aus und schreibe das
  2158. ;; Ergebnis in den Haupt-Text.
  2159. ;; Vorläufige Version: Keine Umleitung von *query-io* und *debug-io* auf
  2160. ;; Fenster.
  2161. (defun eval-region (screen lin1 col1 lin2 col2)
  2162.   (unless lin1 (return-from eval-region nil))
  2163.   (let* ((errorflag nil)
  2164.          (traceflag nil)
  2165.          (instream (make-read-from-screen-stream screen lin1 col1 lin2 col2))
  2166.          (*standard-output* (make-write-to-screen-stream main-screen))
  2167.          (*error-output*
  2168.            (make-write-to-screen-stream-with-flag error-screen errorflag))
  2169.          (*trace-output*
  2170.            (make-write-to-screen-stream-with-flag trace-screen traceflag))
  2171.          (results
  2172.            (multiple-value-list (with-trapped-errors (eval (read instream))))
  2173.         ))
  2174.     (close instream)
  2175.     ;; Werte dazu
  2176.     (unless (or (null results) errorflag)
  2177.       (fresh-line)
  2178.       (loop
  2179.         (prin1 (pop results))
  2180.         (when (null results) (return))
  2181.         (write-char #\Space) (write-char #\;) (terpri)
  2182.     ) )
  2183.     (fresh-line)
  2184.     (close *standard-output*)
  2185.     (close *error-output*)
  2186.     (close *trace-output*)
  2187.     (when errorflag (throw 'edit '(:ERROR)))
  2188.     (when traceflag (throw 'edit '(:TRACE)))
  2189.     t
  2190. ) )
  2191.  
  2192. ;; Lies ein Objekt aus dem Block, werte es aus und schreibe das Ergebnis
  2193. ;; in den Text.
  2194. (defun eval-block (screen)
  2195.   #+DEUTSCH "Block-Inhalt auswerten"
  2196.   #+ENGLISH "evaluate block contents"
  2197.   (multiple-value-call #'eval-region screen (get-block screen))
  2198. )
  2199.  
  2200. (defun get-whitespace-right (screen &optional (lin (screen-lin screen))
  2201.                                               (col (screen-col screen)) )
  2202.   (let* ((text (screen-text screen))
  2203.          (text-len-1 (1- (length text)))
  2204.          (line (aref text lin)))
  2205.     (loop
  2206.       (let ((col1 (position #\Space line :start col :test-not #'eql)))
  2207.         (when col1 (return (values lin col1)))
  2208.       )
  2209.       (when (eql lin text-len-1) (return nil))
  2210.       (incf lin)
  2211.       (setq col 0)
  2212.       (setq line (aref text lin))
  2213. ) ) )
  2214.  
  2215. (defun skip-whitespace-right (screen)
  2216.   #+DEUTSCH "Whitespace nach rechts überspringen"
  2217.   #+ENGLISH "skip whitespace right"
  2218.   (multiple-value-bind (lin col) (get-whitespace-right screen)
  2219.     (and lin
  2220.          (set-cursor screen lin col)
  2221. ) ) )
  2222.  
  2223. ; Eine Kopie der Readtable *readtable*, modifiziert für den Syntaxcheck.
  2224. (defun modified-readtable ()
  2225.   (let ((readtable (copy-readtable)))
  2226.     (set-macro-character #\|
  2227.       #'(lambda (stream char)
  2228.           (declare (ignore char))
  2229.           (when (eql (peek-char nil stream nil) #\#)
  2230.             (error #+DEUTSCH "~S von ~S: |# ist nur nach #| zulässig."
  2231.                    #+ENGLISH "~S from ~S: |# is legal only after #|"
  2232.                    'read stream
  2233.         ) ) )
  2234.       nil ; terminating macro character
  2235.       readtable
  2236.     )
  2237.     readtable
  2238. ) )
  2239.  
  2240. (defun get-next-object (screen &optional (old-lin (screen-lin screen))
  2241.                                          (old-col (screen-col screen))
  2242.                                          (readtable (modified-readtable)) )
  2243.   (multiple-value-bind (lin col) (get-whitespace-right screen old-lin old-col)
  2244.     (if lin
  2245.       (multiple-value-bind (instream get-end-pos)
  2246.           (make-read-from-screen-stream screen lin col)
  2247.         (unwind-protect
  2248.           (if (eq (with-ignored-errors ; Errors abfangen
  2249.                     (let ((*read-suppress* t) ; nur Syntaxcheck
  2250.                           (sys::*backquote-level* most-positive-fixnum) ; Bei Komma kein Error!
  2251.                           (*readtable* readtable)) ; |# soll Error liefern
  2252.                       (read-preserving-whitespace instream t nil t)
  2253.                   ) )
  2254.                   errorval
  2255.               )
  2256.             (values nil nil nil nil)
  2257.             (multiple-value-call #'values lin col (funcall get-end-pos))
  2258.           )
  2259.           (close instream)
  2260.       ) )
  2261.       (values nil nil nil nil)
  2262. ) ) )
  2263.  
  2264. (defun mark-next-object (screen)
  2265.   #+DEUTSCH "Nächstes LISP-Objekt markieren"
  2266.   #+ENGLISH "mark next Lisp object"
  2267.   (multiple-value-call #'mark-region screen (get-next-object screen))
  2268. )
  2269.  
  2270. (defun get-toplevel-form (screen)
  2271.   (let ((text (screen-text screen))
  2272.         (lin (screen-lin screen))
  2273.         (col (screen-col screen)))
  2274.     ;; Klettere Zeilen hoch. Zeilen, die (nach evtl. Spaces) mit Semikolon
  2275.     ;; oder Klammer zu beginnen, werden ignoriert. Zeilen, deren Einrücktiefe
  2276.     ;; größer als eine weiter unten angetroffene ist, werden ebenfalls
  2277.     ;; ignoriert. Passiert eine Zeile diese Kriterien, wird versucht, ab ihr
  2278.     ;; zu lesen, und zwischen dem Ende der dabei erkannten Form und der
  2279.     ;; aktuellen Position darf nur Whitespace vorkommen.
  2280.     ; 1. Schritt: Whitespace nach links übergehen:
  2281.     (let ((line (aref text lin)))
  2282.       (loop
  2283.         (let ((col1 (position #\Space line :end col :test-not #'eql :from-end t)))
  2284.           (when col1 ; Non-Space gefunden, col verkleinern
  2285.             (setq col (1+ col1))
  2286.             (return)
  2287.           )
  2288.           ; Keines gefunden, probiere Zeile davor:
  2289.           (when (eql lin 0) (setq col 0) (return))
  2290.           (decf lin)
  2291.           (setq line (aref text lin))
  2292.           (setq col (length line))
  2293.     ) ) )
  2294.     ; 2. Schritt: Hochklettern:
  2295.     (let ((readtable (modified-readtable)) ; modifizierte Readtable pre-allozieren
  2296.           (lin1 lin)
  2297.           (older-marks '())
  2298.           (older-indent most-positive-fixnum))
  2299.       (loop
  2300.         (let* ((line (aref text lin1))
  2301.                (indent (position #\Space line :test-not #'eql)))
  2302.           (when (and indent
  2303.                      (not (member (char line indent) '( #\; #\) ))) ; (
  2304.                      (<= indent older-indent)
  2305.                 )
  2306.             (setq older-indent indent)
  2307.             (multiple-value-bind (lin0 col0 lin2 col2)
  2308.                 (get-next-object screen lin1 indent readtable)
  2309.               (when lin0
  2310.                 ; Ein Objekt geht von (lin0,col0) bis (lin2,col2).
  2311.                 (when (or (< lin0 lin)
  2312.                           (and (= lin0 lin) (<= col0 col))
  2313.                       )
  2314.                   ; Es fängt vor (lin,col) an.
  2315.                   (when (or (< lin lin2)
  2316.                             (and (= lin lin2) (<= col col2))
  2317.                         )
  2318.                     ; Es hört hinter (lin,col) auf.
  2319.                     (push (list lin0 col0 lin2 col2) older-marks)
  2320.         ) ) ) ) ) )
  2321.         (when (eql lin1 0) (return))
  2322.         (decf lin1)
  2323.       )
  2324.       ; Wenn passende Objekte gefunden wurden, dann liefere den äußersten:
  2325.       (if older-marks
  2326.         (values-list (first older-marks))
  2327.         (values nil nil nil nil)
  2328.       )
  2329. ) ) )
  2330.  
  2331. (defun mark-toplevel-form (screen)
  2332.   #+DEUTSCH "Toplevel-Form markieren"
  2333.   #+ENGLISH "mark surrounding top level form"
  2334.   (multiple-value-call #'mark-region screen (get-toplevel-form screen))
  2335. )
  2336.  
  2337. (defun eval-toplevel-form (screen)
  2338.   #+DEUTSCH "Toplevel-Form auswerten"
  2339.   #+ENGLISH "evaluate surrounding top level form"
  2340.   (multiple-value-call #'eval-region screen (get-toplevel-form screen))
  2341. )
  2342.  
  2343. (defun get-next-tab-pos (screen lin col)
  2344.   (let* ((text (screen-text screen))
  2345.          (line (aref text lin))
  2346.          (line-len (length line))
  2347.         )
  2348.     (cond ((>= col line-len) line-len)
  2349.           ((eql (char line col) #\Space)
  2350.             (or (position #\Space line :start col :test-not #'eql) line-len)
  2351.           )
  2352.           ((eql (char line col) #\( ) ; )
  2353.             (min (+ col 2) line-len)
  2354.           )
  2355.           (t (let ((col1 (position #\Space line :start col)))
  2356.                (if col1
  2357.                  (or (position #\Space line :start col1 :test-not #'eql)
  2358.                      line-len
  2359.                  )
  2360.                  line-len
  2361. ) ) )     )  ) )
  2362.  
  2363. (defun cursor-to-col (screen col)
  2364.   (let* ((text (screen-text screen))
  2365.          (lin (screen-lin screen))
  2366.          (line (aref text lin))
  2367.          (line-len (length line))
  2368.         )
  2369.     (when (> col line-len)
  2370.       (resize-array line col)
  2371.       (fill line #\Space :start line-len)
  2372.       (refresh-line screen lin line-len)
  2373.     )
  2374.     (set-cursor screen lin col)
  2375. ) )
  2376.  
  2377. (defun next-indent (screen)
  2378.   #+DEUTSCH "Leerstellen bis zur nächsten Einrückung"
  2379.   #+ENGLISH "insert spaces up to next tab stop"
  2380.   (let ((lin (screen-lin screen))
  2381.         (col (screen-col screen)))
  2382.     (if (eql lin 0)
  2383.       (cursor-to-col screen (+ col 2))
  2384.       (cursor-to-col screen (get-next-tab-pos screen (1- lin) col))
  2385. ) ) )
  2386.  
  2387. (defvar *search-string* "") ; String, nach dem gesucht werden soll
  2388.  
  2389. (defun search-first (screen)
  2390.   #+DEUTSCH "Nach Textstück Suchen"
  2391.   #+ENGLISH "search for a string"
  2392.   (setq *search-string*
  2393.     (line-edit #+DEUTSCH " Suche: "
  2394.                #+ENGLISH " Search: "
  2395.                *search-string*
  2396.   ) )
  2397.   (search-next screen)
  2398. )
  2399.  
  2400. (defun search-next (screen)
  2401.   #+DEUTSCH "Weitersuchen"
  2402.   #+ENGLISH "continue searching"
  2403.   (let* ((text (screen-text screen))
  2404.          (lin (screen-lin screen))
  2405.          (col (screen-col screen))
  2406.          (text-len (length text))
  2407.          (index (if (< col (length (aref text lin)))
  2408.                   (search *search-string* (aref text lin) :start2 (1+ col))
  2409.                   nil
  2410.         ))      )
  2411.     (if index
  2412.       (set-cursor screen lin index)
  2413.       (loop (when (eql (incf lin) text-len) (return nil))
  2414.             (setq index (search *search-string* (aref text lin)))
  2415.             (when index (return (set-cursor screen lin index)))
  2416. ) ) ) )
  2417.  
  2418. ;===========================================================================
  2419. ;                        T A S T E N B E L E G U N G
  2420. ;===========================================================================
  2421.  
  2422. ;; Brunos Tastenbelegung:
  2423.  
  2424. #+(or ATARI DOSE)
  2425. (progn
  2426.  
  2427. (defun C-H-doc (n)
  2428.   (format nil #+DEUTSCH "Fenster Nr. ~D nach oben bringen"
  2429.               #+ENGLISH "show window ~D"
  2430.           (1+ n)
  2431. ) )
  2432. (defun M-H-doc (n)
  2433.   (format nil #+DEUTSCH "Fenster Nr. ~D unsichtbar machen"
  2434.               #+ENGLISH "hide window ~D"
  2435.           (1+ n)
  2436. ) )
  2437.  
  2438. (bind-key #\C-F1       :control '(:TOP 0) (C-H-doc 0))
  2439. (bind-key #\C-F2       :control '(:TOP 1) (C-H-doc 1))
  2440. (bind-key #\C-F3       :control '(:TOP 2) (C-H-doc 2))
  2441. (bind-key #\C-F4       :control '(:TOP 3) (C-H-doc 3))
  2442. (bind-key #\C-F5       :control '(:TOP 4) (C-H-doc 4))
  2443. (bind-key #\C-F6       :control '(:TOP 5) (C-H-doc 5))
  2444. (bind-key #\C-F7       :control '(:TOP 6) (C-H-doc 6))
  2445. (bind-key #\C-F8       :control '(:TOP 7) (C-H-doc 7))
  2446. (bind-key #\C-F9       :control '(:TOP 8) (C-H-doc 8))
  2447. (bind-key #\C-F10      :control '(:TOP 9) (C-H-doc 9))
  2448.  
  2449. #+ATARI
  2450. (bind-key #\Help       :control '(:HELP) #+DEUTSCH "Hilfefenster (diesen Text) nach oben bringen"
  2451.                                          #+ENGLISH "show help window (this text)"
  2452. )
  2453. #+DOSE
  2454. (bind-key #\M-H        :control '(:HELP) #+DEUTSCH "Hilfefenster (diesen Text) nach oben bringen"
  2455.                                          #+ENGLISH "show help window (this text)"
  2456. )
  2457.  
  2458. (bind-key #\C-E        :control '(:ERROR) #+DEUTSCH "Errorfenster nach oben bringen"
  2459.                                           #+ENGLISH "show error window"
  2460. )
  2461. (bind-key #\C-T        :control '(:TRACE) #+DEUTSCH "Tracefenster nach oben bringen"
  2462.                                           #+ENGLISH "show trace window"
  2463. )
  2464.  
  2465. (bind-key #\M-F2       :control '(:HIDE 1) (M-H-doc 1))
  2466. (bind-key #\M-F3       :control '(:HIDE 2) (M-H-doc 2))
  2467. (bind-key #\M-F4       :control '(:HIDE 3) (M-H-doc 3))
  2468. (bind-key #\M-F5       :control '(:HIDE 4) (M-H-doc 4))
  2469. (bind-key #\M-F6       :control '(:HIDE 5) (M-H-doc 5))
  2470. (bind-key #\M-F7       :control '(:HIDE 6) (M-H-doc 6))
  2471. (bind-key #\M-F8       :control '(:HIDE 7) (M-H-doc 7))
  2472. (bind-key #\M-F9       :control '(:HIDE 8) (M-H-doc 8))
  2473. (bind-key #\M-F10      :control '(:HIDE 9) (M-H-doc 9))
  2474.  
  2475. (bind-key #\M-Q        :control '(:DELETE) #+DEUTSCH "oberes Fenster wegwerfen"
  2476.                                            #+ENGLISH "delete current window"
  2477. )
  2478. (bind-key #\M-X        :control '(:LOAD) #+DEUTSCH "File laden"
  2479.                                          #+ENGLISH "load file"
  2480. )
  2481. (bind-key #\M-S        :control '(:SAVE) #+DEUTSCH "oberes Fenster abspeichern"
  2482.                                          #+ENGLISH "store to file"
  2483. )
  2484. (bind-key #\M-W        :control '(:SAVE-AS) #+DEUTSCH "oberes Fenster als neues File abspeichern"
  2485.                                             #+ENGLISH "store to new file"
  2486. )
  2487.  
  2488. (bind-key #\Escape     :control '(:LEAVE) #+DEUTSCH "Editor verlassen"
  2489.                                           #+ENGLISH "quit editor"
  2490. )
  2491.  
  2492. (bind-key :string-char :writable #'insert-char)
  2493.  
  2494. ;; Ziffernblock wie gewöhnliche Tasten behandeln, dazu Shift-Space
  2495. (dolist (c '(#\( #\) #\+ #\- #\* #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\. #\,))
  2496.   (let* ((c c)
  2497.          (keypad-c (set-char-bit c :hyper t))
  2498.          (sh-keypad-c (set-char-bit c :super t)))
  2499.     (bind-key (list keypad-c sh-keypad-c)
  2500.               :writable
  2501.               #'(lambda (screen) (insert-char screen c))
  2502. ) ) )
  2503. #-DOSE (bind-key #\S-Space     :writable  #'(lambda (screen) (insert-char screen #\Space)))
  2504. #+DOSE (progn
  2505. (bind-key #\F11         :writable  #'(lambda (screen) (insert-char screen #\()))
  2506. (bind-key #\F12         :writable  #'(lambda (screen) (insert-char screen #\))))
  2507. )
  2508.  
  2509. (bind-key #\Up          :multiline 'cursor-up)
  2510. (bind-key #\Down        :multiline 'cursor-down)
  2511. (bind-key #\Left        :all       'cursor-left)
  2512. (bind-key #\Right       :all       'cursor-right)
  2513. #-DOSE (progn
  2514. (bind-key #\S-Up        :multiline 'line-up)
  2515. (bind-key #\S-Down      :multiline 'line-down)
  2516. (bind-key #\C-Up        :multiline 'page-up)
  2517. (bind-key #\C-Down      :multiline 'page-down)
  2518. (bind-key #\S-Left      :all       'cursor-to-start-of-line)
  2519. (bind-key #\S-Right     :all       'cursor-to-end-of-line)
  2520. )
  2521. #+DOSE (progn
  2522. (bind-key #\C-Up        :multiline 'line-up)
  2523. (bind-key #\C-Down      :multiline 'line-down)
  2524. (bind-key #\PgUp        :multiline 'page-up)
  2525. (bind-key #\PgDn        :multiline 'page-down)
  2526. (bind-key #\Home        :all       'cursor-to-start-of-line)
  2527. (bind-key #\End         :all       'cursor-to-end-of-line)
  2528. )
  2529.  
  2530. ; Emacs-like:
  2531. (bind-key #\C-P         :multiline 'cursor-up)
  2532. (bind-key #\C-N         :multiline 'cursor-down)
  2533. (bind-key #\C-S         :all       'cursor-left)
  2534. (bind-key #\C-D         :all       'cursor-right)
  2535. #-DOSE (progn
  2536. (bind-key #\S-C-P       :multiline 'line-up)
  2537. (bind-key #\S-C-N       :multiline 'line-down)
  2538. (bind-key #\S-C-S       :all       'cursor-to-start-of-line)
  2539. (bind-key #\S-C-D       :all       'cursor-to-end-of-line)
  2540. )
  2541.  
  2542. #+ATARI (progn
  2543. (bind-key #\Home        :multiline 'cursor-to-start-of-text)
  2544. (bind-key #\S-Home      :multiline 'cursor-to-end-of-text)
  2545. )
  2546. #+DOSE (progn
  2547. (bind-key #\C-PgUp      :multiline 'cursor-to-start-of-text)
  2548. (bind-key #\C-PgDn      :multiline 'cursor-to-end-of-text)
  2549. )
  2550.  
  2551. (bind-key #\C-B         :all       'set-block-start)
  2552. (bind-key #\C-K         :all       'set-block-end)
  2553. (bind-key #\M-B         :all       'cursor-to-start-of-block)
  2554. (bind-key #\M-K         :all       'cursor-to-end-of-block)
  2555. (bind-key #\C-H         :all       'hide-block)
  2556.  
  2557. (bind-key '(#\Return #\Enter) :and-writable-multiline 'insert-line)
  2558. (bind-key '(#\Return #\Enter) :and-writable-not-multiline 'finish)
  2559. (bind-key #\C-Y         :and-writable-multiline 'delete-line)
  2560. (bind-key #\C-J         :and-writable-multiline 'combine-lines)
  2561. (bind-key #\Delete      :writable  'delete-char)
  2562. #+ATARI (progn
  2563. (bind-key #\S-Delete    :and-writable-multiline 'delete-char-1)
  2564. (bind-key #\S-Delete    :and-writable-not-multiline 'delete-char)
  2565. )
  2566. #+DOSE (progn
  2567. (bind-key #\C-Delete    :and-writable-multiline 'delete-char-1)
  2568. (bind-key #\C-Delete    :and-writable-not-multiline 'delete-char)
  2569. )
  2570. (bind-key #\Backspace   :writable  'backspace)
  2571. #+ATARI (progn
  2572. (bind-key #\S-Backspace :and-writable-multiline 'backspace-1)
  2573. (bind-key #\S-Backspace :and-writable-not-multiline 'backspace)
  2574. )
  2575. #+DOSE (progn
  2576. (bind-key #\C-Backspace :and-writable-multiline 'backspace-1)
  2577. (bind-key #\C-Backspace :and-writable-not-multiline 'backspace)
  2578. )
  2579.  
  2580. #+ATARI
  2581. (bind-key #\C-Space     :all       'skip-whitespace-right)
  2582. (bind-key #\C-Right     :all       'mark-next-object)
  2583. (bind-key #\C-Enter     :all       'mark-toplevel-form)
  2584. #+ATARI
  2585. (bind-key #\S-Enter     :and-writable-multiline 'eval-toplevel-form)
  2586. #+DOSE
  2587. (bind-key '(#\C-Return #\C-Enter) :and-writable-multiline 'eval-toplevel-form)
  2588. ;(bind-key #\C-E         :and-writable-multiline 'eval-block)
  2589. ;(bind-key #\C-E         :and-writable-multiline 'eval-buffer)
  2590.  
  2591. (bind-key #\C-X         :writable  'delete-block-buffer)
  2592. (bind-key #\C-C         :all       'copy-block-buffer)
  2593. (bind-key #\C-V         :writable  'paste-buffer)
  2594. #+ATARI
  2595. (bind-key #\S-C-X       :writable  'delete-block)
  2596. ;(bind-key #\M-C         :writable  'copy-block)
  2597. ;(bind-key #\M-V         :writable  'move-block)
  2598.  
  2599. (bind-key #\Tab         :writable  'next-indent)
  2600.  
  2601. (bind-key #\C-0         :all       (set-mark-fn 0) (set-mark-doc 0))
  2602. (bind-key #\C-1         :all       (set-mark-fn 1) (set-mark-doc 1))
  2603. (bind-key #\C-2         :all       (set-mark-fn 2) (set-mark-doc 2))
  2604. (bind-key #\C-3         :all       (set-mark-fn 3) (set-mark-doc 3))
  2605. (bind-key #\C-4         :all       (set-mark-fn 4) (set-mark-doc 4))
  2606. (bind-key #\C-5         :all       (set-mark-fn 5) (set-mark-doc 5))
  2607. (bind-key #\C-6         :all       (set-mark-fn 6) (set-mark-doc 6))
  2608. (bind-key #\C-7         :all       (set-mark-fn 7) (set-mark-doc 7))
  2609. (bind-key #\C-8         :all       (set-mark-fn 8) (set-mark-doc 8))
  2610. (bind-key #\C-9         :all       (set-mark-fn 9) (set-mark-doc 9))
  2611. (bind-key #\M-0         :all       (cursor-to-mark-fn 0) (cursor-to-mark-doc 0))
  2612. (bind-key #\M-1         :all       (cursor-to-mark-fn 1) (cursor-to-mark-doc 1))
  2613. (bind-key #\M-2         :all       (cursor-to-mark-fn 2) (cursor-to-mark-doc 2))
  2614. (bind-key #\M-3         :all       (cursor-to-mark-fn 3) (cursor-to-mark-doc 3))
  2615. (bind-key #\M-4         :all       (cursor-to-mark-fn 4) (cursor-to-mark-doc 4))
  2616. (bind-key #\M-5         :all       (cursor-to-mark-fn 5) (cursor-to-mark-doc 5))
  2617. (bind-key #\M-6         :all       (cursor-to-mark-fn 6) (cursor-to-mark-doc 6))
  2618. (bind-key #\M-7         :all       (cursor-to-mark-fn 7) (cursor-to-mark-doc 7))
  2619. (bind-key #\M-8         :all       (cursor-to-mark-fn 8) (cursor-to-mark-doc 8))
  2620. (bind-key #\M-9         :all       (cursor-to-mark-fn 9) (cursor-to-mark-doc 9))
  2621.  
  2622. #+ATARI (progn
  2623. (bind-key #\S-C-Left    :writable  'clear-start-of-line)
  2624. (bind-key #\S-C-Right   :writable  'clear-end-of-line)
  2625. )
  2626. #+DOSE (progn
  2627. (bind-key #\M-Left      :writable  'clear-start-of-line)
  2628. (bind-key #\M-Right     :writable  'clear-end-of-line)
  2629. )
  2630.  
  2631. #+ATARI
  2632. (bind-key #\S-C-L       :multiline 'search-first)
  2633. #+DOSE
  2634. (bind-key #\M-L         :multiline 'search-first)
  2635. (bind-key #\C-L         :multiline 'search-next)
  2636.  
  2637. )
  2638.  
  2639. #+UNIX
  2640. (progn ; noch sehr rudimentär und unvollständig! ??
  2641.  
  2642. (defun C-H-doc (n)
  2643.   (format nil #+DEUTSCH "Fenster Nr. ~D nach oben bringen"
  2644.               #+ENGLISH "show window ~D"
  2645.           (1+ n)
  2646. ) )
  2647.  
  2648. (bind-key #\F1         :control '(:TOP 0) (C-H-doc 0))
  2649. (bind-key #\F2         :control '(:TOP 1) (C-H-doc 1))
  2650. (bind-key #\F3         :control '(:TOP 2) (C-H-doc 2))
  2651. (bind-key #\F4         :control '(:TOP 3) (C-H-doc 3))
  2652. (bind-key #\F5         :control '(:TOP 4) (C-H-doc 4))
  2653. (bind-key #\F6         :control '(:TOP 5) (C-H-doc 5))
  2654. (bind-key #\F7         :control '(:TOP 6) (C-H-doc 6))
  2655. (bind-key #\F8         :control '(:TOP 7) (C-H-doc 7))
  2656. (bind-key #\F9         :control '(:TOP 8) (C-H-doc 8))
  2657. (bind-key #\F10        :control '(:TOP 9) (C-H-doc 9))
  2658.  
  2659. (bind-key #\C-G        :control '(:HELP) #+DEUTSCH "Hilfefenster (diesen Text) nach oben bringen"
  2660.                                          #+ENGLISH "show help window (this text)"
  2661. )
  2662. (bind-key #\C-E        :control '(:ERROR) #+DEUTSCH "Errorfenster nach oben bringen"
  2663.                                           #+ENGLISH "show error window"
  2664. )
  2665. (bind-key #\C-T        :control '(:TRACE) #+DEUTSCH "Tracefenster nach oben bringen"
  2666.                                           #+ENGLISH "show trace window"
  2667. )
  2668.  
  2669. (bind-key #\C-Q        :control '(:DELETE) #+DEUTSCH "oberes Fenster wegwerfen"
  2670.                                            #+ENGLISH "delete current window"
  2671. )
  2672. (bind-key #\C-X        :control '(:LOAD) #+DEUTSCH "File laden"
  2673.                                          #+ENGLISH "load file"
  2674. )
  2675. (bind-key #\C-W        :control '(:SAVE-AS) #+DEUTSCH "oberes Fenster als neues File abspeichern"
  2676.                                             #+ENGLISH "store to new file"
  2677. )
  2678.  
  2679. (bind-key '#\Escape    :control '(:LEAVE) #+DEUTSCH "Editor verlassen"
  2680.                                           #+ENGLISH "quit editor"
  2681. )
  2682.  
  2683. (bind-key :string-char :writable #'insert-char)
  2684.  
  2685. (bind-key #\Up          :multiline 'cursor-up)
  2686. (bind-key #\Down        :multiline 'cursor-down)
  2687. (bind-key #\Left        :all       'cursor-left)
  2688. (bind-key #\Right       :all       'cursor-right)
  2689. (bind-key #\PgUp        :multiline 'page-up)
  2690. (bind-key #\PgDn        :multiline 'page-down)
  2691.  
  2692. ; Emacs-like:
  2693. (bind-key #\C-P         :multiline 'cursor-up)
  2694. (bind-key #\C-N         :multiline 'cursor-down)
  2695. (bind-key #\C-S         :all       'cursor-left)
  2696. (bind-key #\C-D         :all       'cursor-right)
  2697. (bind-key #\C-A         :all       'cursor-to-start-of-line)
  2698. (bind-key #\C-F         :all       'cursor-to-end-of-line)
  2699.  
  2700. (bind-key #\C-B         :all       'set-block-start)
  2701. (bind-key #\C-K         :all       'set-block-end)
  2702. (bind-key #\C-U         :all       'hide-block)
  2703.  
  2704. (bind-key #\Return      :and-writable-multiline 'insert-line)
  2705. (bind-key #\Return      :and-writable-not-multiline 'finish)
  2706. (bind-key #\C-Y         :and-writable-multiline 'delete-line)
  2707. (bind-key #\C-J         :and-writable-multiline 'combine-lines)
  2708. (bind-key '(#\Backspace #\Delete) :writable  'backspace)
  2709.  
  2710. (bind-key #\C-V         :all       'skip-whitespace-right)
  2711. (bind-key #\C-R         :all       'mark-next-object)
  2712. (bind-key '(#\C-O #\F11) :all      'mark-toplevel-form)
  2713. (bind-key '(#\C-L #\F12) :and-writable-multiline 'eval-toplevel-form)
  2714.  
  2715. (bind-key #\Tab         :writable  'next-indent)
  2716.  
  2717. )
  2718.  
  2719. ;; *undo* behandeln ??
  2720. ;; #\C-R für Repeat ??
  2721.  
  2722. ;###############################################################################
  2723.  
  2724. ;; ob der eingebaute Editor benutzt wird:
  2725. (defparameter *use-ed* t)
  2726.  
  2727. (fmakunbound 'ed)
  2728. ; Erweiterte Version von ED in DEFS1.LSP:
  2729. (defun ed (&optional arg &aux funname sym fun def)
  2730.   (if (null arg)
  2731.     (if *use-ed*
  2732.       (edit)
  2733.       (edit-file "")
  2734.     )
  2735.     (if (or (pathnamep arg) (stringp arg))
  2736.       (if *use-ed*
  2737.         (edit `(:LOAD ,(namestring arg)))
  2738.         (edit-file arg)
  2739.       )
  2740.       (if (and (cond ((sys::function-name-p arg) (setq funname arg) t)
  2741.                      ((functionp arg) (sys::function-name-p (setq funname (sys::%record-ref arg 0))))
  2742.                      (t nil)
  2743.                )
  2744.                (fboundp (setq sym (sys::get-funname-symbol funname)))
  2745.                (or (setq fun (macro-function sym))
  2746.                    (setq fun (symbol-function sym))
  2747.                )
  2748.                (functionp fun)
  2749.                (not (compiled-function-p fun))
  2750.                (or (sys::function-name-p arg) (eql fun arg))
  2751.                (setq def (get sym 'sys::definition))
  2752.           )
  2753.         (let ((env (vector (sys::%record-ref fun 4) ; venv
  2754.                            (sys::%record-ref fun 5) ; fenv
  2755.                            (sys::%record-ref fun 6) ; benv
  2756.                            (sys::%record-ref fun 7) ; genv
  2757.                            (sys::%record-ref fun 8) ; denv
  2758.              ))    )
  2759.           (if *use-ed*
  2760.             (edit `(:FORM ,sym ,*package* ,env
  2761.                           ,(write-to-string def :escape t :pretty t)
  2762.             )      )
  2763.             (let ((tempfile (editor-tempfile)))
  2764.               (with-open-file (f tempfile :direction :output)
  2765.                 (pprint def f)
  2766.                 (terpri f) (terpri f)
  2767.               )
  2768.               (edit-file tempfile)
  2769.               (with-open-file (f tempfile :direction :input)
  2770.                 (let ((*package* *package*) ; *PACKAGE* binden
  2771.                       (end-of-file "EOF")) ; einmaliges Objekt
  2772.                   (loop
  2773.                     (let ((obj (read f nil end-of-file)))
  2774.                       (when (eql obj end-of-file) (return))
  2775.                       (print (evalhook obj nil nil env))
  2776.               ) ) ) )
  2777.           ) )
  2778.           funname
  2779.         )
  2780.         (error #+DEUTSCH "~S ist nicht editierbar."
  2781.                #+ENGLISH "~S cannot be edited."
  2782.                #+FRANCAIS "~S ne peut pas être édité."
  2783.                arg
  2784. ) ) ) ) )
  2785.  
  2786.